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ABSTRACT 


We  present  an  algorithm  for  finding  optimal  three-dimensional  paths  above 
polyhedral  models  of  terrain  using  a  technique  we  refer  to  as  "random-ray". 
Contiguous  sequences  of  homogeneous  airspace  volumes  are  generated  using 
constraints  of  probability-of-detection  and  aerodynamic-flight  models.  The  flight 
costs  are  calculated  as  in  actual  mission  planning  using  time,  distance,  airspeed,  and 
fuel  flow.  We  then  try  semi-random  directions  (rays)  from  the  starting  point, 
turning  in  accordance  with  Snell’s  Law  at  maneuver  points  (points  between 
volumes).  If  we  ever  do  not  enter  the  previously  specified  next  volume,  we  make 
random  adjustments  to  the  ray  (in,  out,  up,  or  down)  with  respect  to  the  center  of 
the  facet  between  the  two  volumes,  until  either  the  path  will  enter  the  correct  next 
volume  or  we  determine  it  is  impossible.  The  performance  of  our  random-ray 
technique  is  an  improvement  over  an  earlier  approach  using  local  optimization.  We 
have  also  implemented  a  movable  display  on  a  graphics  workstation,  to  allow  the 
user  the  ability  to  view  the  terrain  and  paths  from  any  angle. 
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L  INTRODUCTION 


Prior  planning  has  always  been  the  key  to  success  of  any  military  mission. 

With  advance  notice,  all  possibilities  can  be  thoroughly  examined  and  die  best 
possible  choices  made.  Unfortunately,  time  is  often  at  such  a  premium  in  last- 
minute  strike  planning  that  all  avenues  of  attack  are  not  fully  exploited. 

Furthermore,  in  today’s  changing  world  we  are  continually  confronted  by  changes  in 
policy,  strategy  and  assets.  A  domino  effect  from  upper  echelons  causes  constant 
turmoil  in  preplanned  strike  packages.  A  faster,  more  efficient  way  of  route 
planning,  and  systems  that  can  detect  the  enemy’s  weakest  avenues  of  approach  are 
needed.  Such  systems  could  also  be  used  to  identify  our  own  deficiencies  and 
allow  for  reinforcements. 

Our  work  at  the  Naval  Postgraduate  School  (NPS)  has  led  to  new  methods  of 
path  planning  using  artificial  intelligence  that  are  more  suited  for  near-real-time  path 
planning.  This  new  approach,  combined  with  proven  algorithms  from  artificial 
intelligence  about  searching  through  sets  of  possible  solutions  to  find  particular  "best 
solutions",  has  allowed  faster  results  to  certain  path-planning  problems  than  was 
previously  possible.  A  program  of  this  type  could  greatly  aid  aircrews  in  their 
mission  planning,  or  add  flexibility  to  path-planning  for  cruise  missiles.  Once  in 
general  use,  where  basic  data  is  already  loaded,  paths  can  be  planned  by  inputting 
the  start  and  goal  points  and  how  many  paths  we  wish  to  consider  and  the  computer 
program,  suitably  optimized,  should  be  able  to  give  us  answers  within  minutes  for 
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many  interesting  problems.  Considering  that  it  takes  an  average  of  two  days  to 
fully  plan  manually  a  single  route  into  hostile  territory,  this  is  a  great  savings.  The 
computer  does  not  forget  special  considerations  under  pressure  and  it  can  give  us  all 
possible  solutions,  not  just  the  obvious  ones. 

Several  programs  have  come  close  to  what  we  are  looking  for  but  have  fallen 
short  for  various  reasons.  Flight  planning  programs  while  giving  accurate  flight 
information  have  no  graphics  display  of  actual  terrain  and  no  path  planning 
Theoretical  development  of  three-dimensional  path  planning  has  occurred  recently 
but  nothing  is  available  for  true  aircraft  models  when  the  searching  to  reduce  the 
probability  of  detection.  Much  work  has  been  done  with  terrain  displays  at  NPS 
but  none  include  path  planning  or  aircraft  realism. 

Our  approach  is  to  implement  all  the  ideas  of  the  last  paragraph  into  one 
system.  We  have  extended  David  Lewis’s  thesis  [Ref.  1]  to  include  aircraft  realism 
in  the  cost  analysis  for  the  search  algorithm,  and  used  a  new  technique  for 
optimization  we  refer  to  as  "random-  ray  optimization".  Additional  work  was  done 
on  visualization  of  the  search  algorithm  and  graphic  display  of  the  final  results. 

The  remaining  sections  of  this  thesis  describe  the  work  mentioned  above. 
Chapter  II  is  a  brief  overview  of  previous  work,  including  a  description  of  other 
programs  available.  For  a  more  through  understanding  it  is  suggested  that  David 
Lewis’s  thesis  [Ref.  1]  be  reviewed.  Chapter  III  discusses  assumptions  made  about 
our  aircraft  (a  pseudo-cruise-missile),  while  Chapter  IV  is  the  detailed  account  of 
algorithms  implemented.  The  results  of  the  implementation  are  given  in  Chapter  V, 
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and  finally  in  Chapter  VI  we  discuss  conclusions,  known  problems,  and 
recommendations  for  further  study. 
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II.  BACKGROUND 


A.  FLIGHT  PLANNING  PROGRAMS 

Flight  planning  is  just  one  small  part  of  an  overall  mission  plan.  The  full 
mission  plan  may  contain  other  items  such  as  target  coordination,  secondary  targets, 
and  route  planning.  Route  planning  is  related  to  flight  planning  in  that  the  route 
must  be  known  in  order  to  compute  fuels  and  attack  times  to  complete  flight 
planning. 


1.  OPARS 

Optimal  Path  Aircraft  Routing  System  (OPARS)  and  similar  flight 
planning  programs  are  used  extensively  by  the  military,  particularly  for  long  haul 
type  aircraft  such  as  C-5’s,  C-141’s  and  C-130’s.[Ref.  2]  OPARS  has  flight 
characteristics  for  the  appropriate  aircraft  available  and  receives  input  from  Fleet 
Numerical  Oceanography  Center  in  Monterey,  California  on  items  such  as  forecast 
winds  and  temperatures.  The  program  can  plan  flights  from  point  to  point  where  the 
points  are  known  points  such  as  TACAN  stations  or  fixes  with  known  latitude  and 
longitude,  giving  priority  to  fuel  consumption  and  avoidance  of  high  winds.  The 
algorithm  used  for  OPARS  is  a  depth-first  search  which  generates  a  series  of 
possible  paths,  and  from  this  series,  the  best  path  is  chosen. 

OPARS  is  a  prior-planning  tool  that  gives  information  from  the  latest 
available  data  with  the  output  accurate  enough  to  be  used  in-flight  as  a  check 
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against  how  far  ahead  or  behind  schedule  the  aircraft  is.  It  is  predominately  a  high- 
altitude  tool,  and  uses  known  points  as  discussed  in  the  previous  paragraph  to  plan 
to.  Our  goal  is  to  evolve  something  that  uses  points  that  it  defines  and  can  be  used 
at  low  altitude  for  detection  avoidance. 

2.  Calculator  Aided  Performance  Planning  System 

Special-purpose  hand-held  calculators  have  been  used  for  flight  planning 
for  tactical  aircraft  such  as  E-2C’s,  E-2B’s  and  A-6’s  [Ref.  3]  and  [Ref.  4].  Prior 
planning  done  on  these  small  devices  is  much  simpler  and  less  error-prone  then 
using  graphical  charts  [Ref.  5].  They  can  be  used  in  the  actual  aircraft  when  a 
change  in  plan  is  desired  or  required  because  of  some  emergency.  The  data 
contained  in  these  machines  is  extremely  accurate  and  is  a  compilation  of  the  data 
contained  in  the  NATOPS  Flight  Manual1.  While  some  of  this  information  is 
contained  in  the  pocket  version  of  the  NATOPS  carried  in  the  aircraft,  it  is  not 
complete. 

The  main  problem  with  this  device  is  that  data  entry  is  no  trivial  matter 
(twenty  or  thirty  steps  on  a  number  key  pad).  There  is  no  way  to  store  the  input  in 
flight  planning,  and  if  there  is  a  change,  go  back  in  and  change  a  few  items.  You 
must  also  know  where  you  are  going  and  how  you  are  going  to  get  there.  But  part 
of  these  programs  are  usable  in  our  program,  the  flight  data  formulas.  These 


‘NATOPS  is  the  Naval  Air  Training  and  Operating  Procedures  Standardization 
Program  which  contains  vital  information  for  the  safe  and  emergency  operation  of  military 
aircraft. 
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formulas  were  coded  in  the  flight  characteristics  section  of  our  program  and  used  by 
the  cost  and  evaluation  section  of  the  search  algorithms. 

3.  Others 

Since  1984,  low  cost  and  improved  performance  of  microcomputers  have 
made  it  practical  to  develop  computer-aided  mission-planning-tools  for  use  at  the 
squadron  level  [Ref.  6].  Some  have  used  the  flight  data  from  NATOPS,  [Ref.  6], 
and  others  have  required  input  of  fuel  consumptions  at  every  stage  of  the  flight. 
Most  have  the  ability  to  store  and  change  the  mission  plan,  but  all  require  that  the 
route  be  known  beforehand. 

B.  THREE-DIMENSIONAL  PATH  PLANNING 
1.  Division  Of  Search  Space 

The  speed  at  which  any  computer  can  solve  a  search  problem  is 
dependent  on  the  search  algorithm  used  and  the  size  of  the  search  space.  If  we 
were  to  divide  a  cube  of  side  one  thousand  into  cubes  of  side  ten,  we  would  have 
one  million  cubes  to  search  through  to  find  a  connected  path  from  some  start  cube 
to  a  goal  cube.  If  we  were  to  make  our  cubes  larger  to  side  twenty  five,  the  search 
space  is  reduced  to  sixty  four  thousand  blocks.  This  is  a  large  reduction  in  size  of 
the  search  space  but  it  is  still  large.  The  complexity  of  a  search  problem  is  directly 
proportional  to  the  search  space  when  it  comes  to  allocating  time  and  space 
resources  for  a  simple  non-heuristic  search  [Ref.  7]. 
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But  the  search  space  need  not  be  subdivided  uniformly.  Earlier  work 
[Ref.  1]  used  the  physical  features  of  polyhedrally-modeled  terrain  for  the  first 
division  of  the  airspace.  We  will  refer  to  these  divisions  of  airspace  as  volumes  as 
they  are  bounded  on  all  sides  and  each  will  have  a  homogeneous  property  of  some 
visibility  constant  Vertical  planes  were  constructed  above  all  ridges  forming 
convex  volumes  so  that  from  any  point  in  a  volume  every  other  point  is  visible. 
Once  observer  data  is  added  to  the  problem,  these  convex  volumes  are  further 
divided  into  visibility  volumes  by  passing  planes  from  the  observer  through  the 
peaks  of  all  ridges.  Each  resulting  volume  has  an  associated  probability  of 
detection  from  each  observer  that  it  is  visible  to.  If  one  volume  is  visible  to 
several  observers,  its  probability  of  detection  is  calculated  assuming  probabilistic 
independence. 


2.  Path  Planning  Algorithm 

An  A*  search  is  used  to  produce  a  connected  path  from  center-of-volume 
to  center-of-volume  in  [Ref  1],  The  A*  search  was  chosen  to  find  good  sequences 
of  volumes  likely  to  enclose  the  optimal  path  because  A*  allows  the  use  of  an 
agenda,  an  evaluation  function,  and  a  cost  function.  The  [Ref.  1]  program  used  a 
cost  function  that  took  into  account  climb,  dive,  and  amount  of  turn,  all  multiplied 
by  some  function  of  the  probability  of  detection.  The  evaluation  function  was 
calculated  in  a  similar  manner. 

We  still  considered  this  method  of  search  the  best,  but  we  made 
modifications  to  the  cost  and  evaluation  functions.  These  functions  have  been 
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altered  to  reflect  True  Air  Speed  (TAS)  of  the  missile,  weight.  Fuel  Flow  (FF)  and 
Hnv»  spent  in  a  particular  region.  This  was  done  to  ensure  a  more  realistic 
aerodynamic  model  rather  then  the  single  percentages  used  in  [Ref.  1]  and  to  allow 
for  specific  aircraft  data  to  be  encoded  at  a  later  date. 

3.  Optimization  of  Paths 

Once  the  volume  sequences  are  found  in  the  program  of  [Ref.  1],  initial 
paths  are  generated  from  center-of-facet  to  center-of-facet  of  the  polyhedron  through 
the  search  space.  This  means  that  the  paths  may  go  a  considerable  distance  out  of 
their  way  if  only  a  comer  of  the  volume  need  be  passed  through.  [Ref.  1]  used  a 
modification  to  Snell’s  Law  to  move  the  facet  intersection  points  to  try  to  minimize 
the  error  in  the  Snell’s  Law  equation.  This  is  repeatedly  applied  to  a  path  until  the 
desired  tolerance  is  obtained.  The  problem  encountered  was  that  the  process  would 
get  stuck  on  local  optimization.  This  happens  at  irregular  intervals  and  can 
therefore  not  be  anticipated  and  corrected. 

C.  WORK  IN  COMPUTER  GRAPHICS  DISPLAYS 

Recent  work  at  NPS  has  explored  the  use  of  graphic  displays  to  present  real 
terrain  from  elevation  data.  One  of  the  most  recent  of  these  reads  in  the  terrain 
data  base  and  allows  the  user  to  select  a  segment  of  this  for  a  three-dimensional 
view  of  the  terrain  from  various  platforms  such  as  jeeps,  trucks,  tanks  and  even  a 
missile  [Ref.  8).  Control  inputs  for  the  missile  are  via  dials  for  altitude,  speed  and 
direction.  This  would  be  good  for  output  from  our  program,  but  this  software  at 
present  does  not  display  the  missile  path  nor  is  there  any  intelligent  path  planning. 
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m.  APPLICATION  AND  ASSUMPTIONS 


A.  REAL  WORLD  PROBLEMS 

Flight  planning  is  a  tedious,  calculation-intensive  and  error-prone  process. 

Many  hours  of  planning  can  be  wiped  away  by  a  simple  change  in  commands  from 
higher  authority  or  new  intelligence  data  on  the  location  of  a  missile  or  radar  site. 
Some  target  areas  are  so  saturated  with  defenses  that  there  exists  no  good  way  to 
attack,  only  the  least  hazardous.  In  these  situations  it  is  difficult  for  any  human  to 
rationally  plan  a  route  into  a  target  he  knows  he  may  never  come  out  of.  Likewise, 
when  planning  for  the  cruise  missile  to  destroy  a  site  that  will  open  a  path  that  is 
critical  for  other  aircraft  to  take,  it  is  essential  that  the  path  chosen  for  this  missile 
is  survivable. 

This  type  of  planning  can  become  an  overpowering  task.  For  this  and  many 
other  reasons,  U.S.  Naval  Instructions  require  that  aircrews  be  given  the  opportunity 
for  eight  hours  of  rest  prior  to  flying.  In  some  cases  this  is  not  possible,  so 
anything  that  will  help  lighten  the  workload  is  a  big  plus.  Powerful  computer 
programs  can  help  with  the  mass  of  calculations  required  for  the  single  flight  of  an 
aircraft  or  cruise  missile.  A  program  of  this  type  can  be  used  in  the  strategy 
planning  room  at  the  Wing  or  Battle  Group  level,  or  by  the  individual  pilot  at  the 
squadron  level. 
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Higher  headquarters  are  constantly  playing  "what  if'  games  in  contingency 
planning.  Furthermore,  every  time  there  is  a  change  in  situation,  planners  must 
review  all  the  preplanned  strikes  to  ensure  that  they  have  covered  all  the  changes  in 
targets,  defenses  and  missions  that  need  to  be  addressed.  Similarly,  commanders 
must  review  our  own  defensive  posture  to  ensure  we  have  not  left  any  open 
passages. 

When  it  comes  time  for  an  actual  conflict  similar  problems  will  be 
encountered.  The  need  for  computer  simplicity  and  accuracy  is  essential.  The 
computer  can  cut  calculations  to  a  fraction  of  the  time  and  present  many  more  path¬ 
planning  options  than  could  be  produced  by  several  human  planners. 

B.  AIRCRAFT  REALISM 

In  order  to  keep  this  thesis  unclassified,  no  attempt  was  made  to  obtain  any 
classified  documentation  on  the  cruise  missile.  It  is  important  however  to 
understand  what  information  is  needed  so  that  appropriate  substitutions  could  be 
made  for  actual  flight  data  at  a  later  date. 

1.  Physical  Characteristics 

The  model  of  the  cruise  missile  we  used  was  a  variant  of  the  Tomahawk. 
It  measures  approximately  20  feet  with  a  wing  span  of  8  feet  7  inches  and  has  a 
diameter  of  21  inches. [Ref.  9]  The  missile,  with  a  full  fuel  load  of  900  lbs 
(approximately  120  gallons),  weights  2525  lbs.[Ref.  10]  The  engine  used  is  a 
turbofan  developed  by  Williams  Research  Corporation  and  has  a  designation  of 
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F107-WR-100.  This  engine  can  produce  a  static  thrust  of  430  lbs  at  sea  level  and 
has  a  specific  fuel  consumption  of  0.7  lb/lb-hr.[Ref.  11] 

All  the  articles  read  on  the  cruise  missile  indicate  that  the  planned  cruise 
speed  is  around  450  kts.  This  can  be  increased  or  decreased  depending  on  the 
importance  of  achieving  minimum  detection  or  increasing  range.  The  speed  we  will 
assume  in  this  program  is  450  kts.  As  shown  in  Figure  3-1,  the  turn  characteristics 
arc  such  that  the  missile  will  lead  a  turn  by  an  amount  sufficient  to  arrive  wings 


level  on  an  outbound  course  directly  between  the  turn  point  and  the  next 
point.[Ref.  12]  This  turn  has  a  radius  of  5  nm  and  is  accomplished  in  1G  flight  so 
as  to  not  bleed  any  excess  energy  or  require  any  radical  power  changes. 


Fuel  consumption  data 
versus  vehicle  weight  is  listed  in 
column  form  in  Table  3-1  and 
shown  in  graphic  form  in 
Figure  3-2.  The  data  was 
derived  from  graphs  modeled 
after  the  cruise  performance 


TABLE  3-1.  Cruise  Missile  Weight  vs  Fuel 
Flow 


Missile 

Fuel 

Fuel 

Weight 

Remaining 

Flow 

2525 

1225 

350 

2275 

975 

325 

2025 

725 

300 

1775 

475 

285 

1525 

225 

275 

charts  for  the  Grumman  A-6  aircraft,  [Ref.  13].  This  data  is  for  straight  and  level 


flight  assuming  an  average  fuel  flow  of  270  lb/hr  which  will  maintain  the  required 


450  kts.  Equation  3-1  gives  the  computation  for  fuel  remaining  (X)  against  fuel 


flow. 

Fuel  How  =  -1.6e-10  *  X4  +  4.3733e-7  *  X3  - 

3.566e-4  *  X2  +  0.1530066  *  X  +  254.05494  (3-1) 
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Turn  Point  1  Turn  Point  2 


Figure  3-1.  Cruise  Missile  Turn  Characteristics 
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Figure  3-2.  Cruise  Missile  Weight  vs  Fuel  Flow 


At  this  rate  the  900  lbs  of  useable  fuel  will  allow  a  maximum  distance  of  1500  nm. 
The  formula  for  equation  (3-1)  and  (3-2)  were  obtained  by  using  selected  points  of 
graphs  and  using  a  polynomial  curve  approximation  of  degree  four  and  three 
[Ref.  14]. 

For  climbs  and  dives  we  use  a  different  set  of  formulas  modeled  after 
aerodynamic  theory  from  [Ref.  15]  and  personal  experience.  For  a  climb  up  to  20 
degrees  and  a  dive  of  less  then  10  degrees  we  assume  the  missile  adjusts  power  to 
maintain  450  kts.  The  fuel  flow  for  this  power  adjustment  is  given  by  the  equation 

Fuel  How  =  0.01628787  *  X3  + 

0.1037878  *  X2  +  21.40909  *  X  +  300  (3-2) 

where  X  is  the  angle  of  climb  and  is  depicted  graphically  in  Figure  3-3.  For  dives 

steeper  then  -10  degrees  the  missile  will  increase  speed  and  when  it  returns  to  level 

flight  the  engine  will  remain  at  idle  until  such  time  that  the  aircraft  decelerates  to 

450  kts.  For  a  climb  greater  then  20  degrees  the  rate  at  which  airspeed  will  be  lost 

is 

Loss  Rate  =  3kts/(climb  degrees  -  20)/min  (3-3) 

and  the  rate  at  which  this  airspeed  can  be  recovered  is 

Recovery  Rate  =  50kts/min  (3-4) 

which  if  the  speed  is  decreased  to  200  kts  it  will  require  5  minutes  to  accelerate 
back  to  450  kts. 
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FUEL  FLOW  vs 


Angle  of  Cl 


IV.  IMPLEMENTATION 


A.  OVERVIEW 

1.  System  Requirements 

The  path-planning  part  of  the  thesis  was  implemented  on  a  Texas 
Instrument  (TI)  Explorer  II  LISP  machine  with  16  megabytes  of  memory  and  60 
megabytes  of  virtual  memory.  The  code  is  written  in  Common  LISP  and  makes 
extensive  use  of  the  LISP  Flavor  System.  The  program  forerunner  of  D.  Lewis, 
[Ref.  1],  was  written  in  LISP  because  of  the  advantages  in  speed,  numerical 
accuracy  and  sophisticated  data-structure  management,  and  we  have  continued  with 
LISP  for  these  same  reasons  [Ref.  1:64].  Since  the  project  was  started  there  have 
been  two  upgrades  in  the  operating  system  with  no  problems  or  re-coding  required. 
The  program  will  also  run  on  a  TI  Explorer  I  LISP  machine  if  sufficient  memory  is 
available  but  at  a  large  increase  in  execution  time. 

2.  Main  Program  Parts 

The  program  can  be  broken  into  three  main  sections  (Figure  4-1):  terrain 
input  and  processing,  observer  input  and  processing,  and  path  planning  and 
optimization.  The  first  two  sections  have  not  changed  from  [Ref.  1 :77]  and  will  not 
be  discussed  here.  The  final  section  has  significant  differences,  due  particularly  to 
the  use  of  a  quite  different  technique,  "random-ray  optimization".  It  also  has  one 
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Figure  4-1.  Block  Diagram  of  Program  Structure 
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new  display  option  which  allows  the  user  to  observe  the  best  agenda  item  as  it  is 
being  changed  by  the  A*  search. 

3.  Output  Data 

As  in  [Ref.  1],  the  paths  our  program  finds  are  made  up  of  linear  pieces 
beginning  with  the  volume  that  contains  the  start  point  and  ending  with  the  volume 
that  contains  the  goal  point.  This  path  is  further  defined  by  the  individual  facets 
connecting  the  volumes  and  the  turn  points  on  the  facets  that  when  connected  will 
form  a  path  from  the  start  point  to  the  goal  point. 

The  path  can  be  the  input  of  functions  that  will  give  specific  data  about 
it  such  as  length,  travel  time,  visibility  along  each  line  segment,  amount  of  fuel 
used  for  each  segment,  and  total  fuel  used.  From  this  data  paths  can  be  compared, 
and  determinations  made  as  to  which  path  is  best  suited  for  the  particular  mission. 

A  sample  of  this  output  is  given  in  Table  4-1. 

4.  Contributions  of  Others 

The  code  written  by  Lewis  has  been  used  extensively.  [Ref.  1]  Little  or 
no  changes  have  been  made  to  [Ref.  1]  code  up  through  the  path  planning  section. 
The  section  of  code  for  the  A*  search  is  still  used  intact  but  the  cost  and  evaluation 
functions  have  been  completely  rewritten.  For  some  paths  there  are  no  random-ray 
solutions  so  [Ref.  1]  code  for  optimization  of  a  path  was  left  intact.  This  gives  us 
a  way  to  handle  all  situations. 

A  set  of  moving  picture  display  functions  developed  by  Dr.  Sehung 
Kwak  were  added  to  give  the  ability  to  visualize  the  A*  search  as  it 
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TABLE  4-1.  Sample  "Jet  Log"  Type  Output 


>  (path-data  ' Ipath0032l) 


Leg  Total  Leg 

Total 

Leg 

Fuel 

Vol 

PD 

Leg 

Point  Time  Time  Dist 

(10.0  0.0  300.0) 

Dist 

Fuel 

Remain 

PD 

Cost 

Cost 

0.0  0.0  0.0 
(469.23077  300.0  601.53845) 

0.0 

0.0 

1500 

~ 

— 

— 

73.1  73.1  548.5 

(111.53846  500.0  346.92307) 

548.5 

367.0 

1133.0 

0.070 

512.0 

879.0 

54.6  127.8  409.8 

(111.53846  462.5  287.30768) 

958.3 

272.1 

860.9 

0.070 

382.5 

654.6 

5.0  132.8  37.5 

(586.53845  567.5  262.3077) 

995.8 

24.7 

836.2 

0.070 

35.0 

59.7 

64.9  197.6  486.5 

(700.0  700.0  380.0) 

1482.3 

324.2 

512.0 

0.000 

0.0 

324  .2 

23.3  220.9  174.4 

(420.0  852.5  505.0) 

1656.8 

116.8 

395.1 

0.000 

0.0 

116.8 

42.5  263.4  318.8 

(990.0  990.0  990.0) 

1975.6 

213.1 

182.0 

0.000 

0.0 

213.1 

78.2  341.6  586.3 

Total  cost  of  this  path  -  3187. 

minimum  PD  cost  -  0.0 

maximum  PD  cost  -  547.3 

average  PD  cost  -  9.3 

3187. 7761878875613 dO 
>  (path-data  'Ipath0034l) 

2561.9 

,8 

393.1 

-211.1 

0.070 

547.3 

940.3 

Leg  Total  Leg 

Total 

Leg 

Fuel 

Vol 

PD 

Leg 

Point  Time  Time  Dist 

(10.0  0.0  300.0) 

Dist 

Fuel 

Remain 

PD 

Cost 

Cost 

0.0  0.0  0.0 
(70.92308  300.0  328.15384) 

0.0 

0.0 

1500 

— 

— 

— 

40.8  40.8  306.1 

(73.65098  310.91418  325.41046) 

306.1 

204.2 

1295.8 

0.070 

285.7 

489.9 

1.5  42.3  11.2 

(276.87296  412.58145  300.40717) 

317.4 

7.5 

1288.3 

0.070 

10.5 

18.0 

30.3  72.6  227.2 

(586.53845  567.5  262.3077) 

544.6 

151.4 

1136.9 

0.070 

212.1 

363.5 

46.2  118.8  346.3 

(509.11267  700.0  375.13834) 

890.9 

230.7 

906.3 

0.000 

0.0 

230.7 

20.5  139.2  153.5 

(104.55399  1000.0  500.9108) 

1044.3 

102.8 

803.4 

0.000 

0.0 

102.8 

67.2  206.4  503.7 

(990.0  990.0  990.0) 

1548.0 

336.3 

4  67.1 

0.000 

0.0 

336.3 

118.1  324.5  885.5 

Total  cost  of  this  path  -  2960. 

minimum  PD  cost  -  0.0 

maximum  PD  cost  -  826.5 

average  PD  cost  -  9.1 

2433.5 
,  2 

592.5 

-125.4 

0.070 

826.5 

1419.0 

2960.188312228768d0 


progressed.[Ref.  16]  This  code  originally  written  to  display  one  graphics  window 
and  one  moving  object  was  altered  to  display  several  windows  and  multiple  objects. 


5.  Data  Structures 


The  data  structures  have  not  changed  in  any  area  except  for  the  agenda 
in  path  planning.  The  agenda  now  contains  the  fuel  remaining  at  each  turn  point  so 
the  next  leg’s  fuel  flow  can  be  calculated,  and  the  last  airspeed  must  be  retained  so 
we  know  where  to  start  our  calculations  for  time  and  distance. 

6.  Deviations  From  Total  Path-Planning 

It  was  initially  intended  to  include  all  aspects  of  path-planning  in  our 
new  path-planning  method  but  due  to  time-constraints  and  the  complexity  of  the 
problem  planning  around  obstacles,  except  for  the  minor  cases,  was  left  out. 
Obstacle-traversal  by  paths  would  have  required  additional  algorithms  in  the  A* 
search  and  the  optimization  phase  that  would  allow  the  paths  to  be  sectioned,  thus 
complicating  matters. 

B.  NEW  PATH-PLANNING  METHODS 
1.  Initial  Path-Planning 

Path  planning  begins  by  initializing  the  start  and  goal  point  with  INIT- 
POINT.  These  points  are  passed  to  the  search  function  A-STAR-SEARCH  or  A- 
STAR-SEARCH-M.  An  additional  switch  has  been  added  to  these  two  functions 
and  if  set  to  true,  the  best  path  on  the  agenda  will  be  displayed  as  the  search 
progresses.  Figure  4-2.  The  two  upper  and  lower  left  displays  clear  each  time  a 
new  path  is  made  and  the  fourth  displays  all  lines  as  they  are  generated.  The  final 
display  will  show  all  the  final  paths  from  start  to  goal. 
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Path-over - gr ound 


Figure  4-2.  Search  Display 
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The  cost  function  consists  of  two  parts,  a  probability  of  detection  (PD) 
cost  and  the  cost  of  fuel  used  to  get  from  one  point  to  another.  The  PD  cost  is 
calculated  using 

PDcost  =  probability-of-detection  *  time-in-volumes  *  100  (4-1) 

where  the  extra  100  is  multiplied  in  to  weight  the  PDcost  to  an  amount  comparable 
to  the  basic  cost  This  causes  a  short  stay  in  a  volume  of  high  probability  of 
detection  to  be  preferred  over  a  long  stay  in  a  volume  of  medium  probability  of 
detection.  It  also  forces  the  searcher  to  look  for  volumes  with  zero  probability  of 
detection.  The  fuel-burned  cost  is  related  to  the  distance  flown  and  how  much 
climbing  and  diving  is  done,  as  discussed  in  the  previous  chapter.  Because  of 
nonlinear  aerodynamics,  a  missile  or  aircraft  does  not  gain  back  the  fuel  it  lost  in  a 
climb  if  it  descends  back  to  the  same  level  [Ref.  17].  For  this  reason,  paths  that 
remain  at  a  constant  altitude  are  preferred. 

The  evaluation  function  is  a  calculation  of  the  fuel  cost  from  our  current 
location  directly  to  our  goal  point  ignoring  obstacles.  No  attempt  was  made  to  add 
in  a  PD  cost  as  we  do  not  know  what  volumes  we  will  be  going  through  or  the 
time  we  will  spend  in  them. 


2.  Aircraft  Data 

^  The  cost  and  evaluation  functions  receive  all  of  their  input  on  aircraft 
data  from  the  aircraft  control  module.  Inputs  to  this  module  include  the  distance 
traveled  (not  just  ground  distance),  the  climb  angle,  the  fuel  remaining,  and  current 
airspeed.  The  program  limits  the  fuel  flow  to  an  idle  setting  of  80  lb/hr  which  is 
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the  setting  in  a  ten  degree  dive  and  a  maximum  of  900  lb/hr  at  maximum  power. 
The  module  returns  the  fuel  burned  on  that  leg,  fuel  remaining  and  new  airspeed. 

3.  Random  Ray  Optimization 

The  random-ray  technique  is  applied  to  the  best  connected  sequences  of 
volumes  from  start  to  goal  that  were  found  by  the  A*  search.  This  technique  for  a 
particular  volume  sequence  can  be  broken  into  three  parts:  finding  a  path  into  the 
final  volume,  adjusting  the  path  as  close  to  the  goal  point  as  possible,  and 
calculating  additional  path  details.  The  last  part  is  required  because  due  to  the 
number  of  lines  and  points  generated  during  the  adjustment  phase,  minimal  data  is 
kept  for  each. 

To  start,  a  line,  a  "random-ray",  is  passed  from  the  start  point  to  the  goal 
point.  This  ray  is  examined  to  determine  if  it  passes  into  the  specified  second 
volume  via  the  connecting  facet  (the  plane  connecting  the  two  volumes).  If  it  does 
not,  a  guess  adjustment  is  made  to  the  ray  using  an  adjustment  vector  calculated 
from  the  actual  intersect  point  on  the  extended  facet  to  the  center  of  the  facet 
(Figure  4-3).  The  adjustment  vector  is  multiplied  by  an  adjustment  factor  (initially 
125)  and  then  added  to  the  end  point  of  the  ray  to  obtain  a  new  random-ray. 

These  adjustments  are  continued,  each  time  dividing  the  adjustment  factor  by  five  if 
the  distance  we  are  missing  the  facet  by  is  increasing,  until  the  path  intersects  the 
facet.  We  then  calculate  the  outbound  ray  using  Snell’s  Law  (described  below)  and 
find  the  next  line  segment  in  the  path. 
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Calculations  are  made  at  each  facet  to  find  the  outbound  line  that  meets 
the  criterion  of  Snell’s  Law.  Formulas  were  developed  for  a  known  inbound  ray  to 
the  facet,  the  plane  that  the  facet  lies  in,  and  the  amount  of  bending  the  ray  must 
do  according  to  Snell’s  Law  (Figure  4-4).  Assume  the  equation  of  the  plane 
containing  the  facet  is 

Ax  +  By  +  Cz  +  1  =  0  (4-1) 

where  (A  B  C)  is  the  vector  normal  to  the  plane.  Using  the  point  of  intersection  of 
our  inbound  ray  and  (A  B  C)  (the  vector  normal),  we  generate  a  line  perpendicular 
to  the  facet.  Once  two  lines  are  obtaied  we  can  generate  a  plane,  equation  (4-2), 


contaning  both. 

A2x  +  B2y  +  C2z  +1=0  (4-2; 

We  know  the  unit  direction  vector  (ij  j  j  kj)  of  the  inbound  line  and  are  trying  to 
find  the  unit  direction  vector  j2  k2)  of  the  outbound  line.  We  have  then  three 
equations  in  these  three  unknowns: 

A2(i2)  +  B2(j2)  +  C2(k2)  =  0  (4-3 

(ij)(i2)  +  0'])(j2)  +  =  sin(theta2  -  theta  j)  (4-4 

i2^  +  j2^  +  k2^  =  1  (4-5 

Thetaj  is  given  and  is  the  angle  between  the  inbound  ray  and  the  facet  normal 
(Figure  4-4).  Theta2  can  be  calculated  using  equation  (4-6)  where  PD1  and  PD2 
are  the  respective  volume’s  probability  of  detection. 

Theta2  =  arcsin(PDl  *  (sin  Thetaj)  /  PD2)  (4-6 

We  can  solve  in  terms  of  any  one  of  i2,  j2,  or  k2  and  substitute  this  into  equation 
(4-5),  which  is  easily  solved  using  the  quadratic  formula.  As  it  turns  out,  we  need 
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Figure  4-4.  Snell’s  law 
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all  three  of  j2  to  avoid  a  possible  divide-by-zero  error.  We  also  want  to 
avoid  complex  roots;  if  the  square  root  of  a  negative  number  is  about  to  be  taken, 
we  check  to  see  if  that  number  is  approximately  zero,  and  make  it  zero.  If 
however  these  two  errors  can  not  be  avoided,  the  program  is  terminated  indicating 
that  no  random-ray  solution  is  possible. 

Once  we  have  found  the  outbound  ray  and  know  the  point  of  intersection 
with  the  next  facet  plane,  we  can  construct  the  outbound  line  segment  This  ray 
can  be  adjusted  to  hit  within  the  facet  as  with  the  first  ray.  If  this  adjustment 
causes  the  ray  to  miss  any  of  the  previous  facets,  the  adjustment  is  thrown  out  and 
a  new  guess  is  made.  This  is  done  for  every  successive  facet  of  the  volume 
sequence,  until  we  intersect  the  facet  connected  to  the  final  volume.  Now  our 
target  has  changed;  we  are  now  shooting  for  a  point  in  space  rather  then  a  window. 
The  adjustment  technique  remains  the  same  except  we  make  adjustments  in  smaller 
increments.  Figure  4-5  shows  the  path  generated  by  connecting  the  centers  of  the 
facets  of  the  volumes  found  by  the  A*  search,  and  a  straight-line  path  from  start  to 
goal.  Figure  4-6  and  Figure  4-7  show  adjustments  needed  to  enter  the  goal  volume 
and  Figure  4-8  shows  adjustment  onto  the  goal  point.  An  analogy  of  all  of  this  is 
adjusting  artillery  fire  onto  a  target,  the  only  difference  being  that  we  do  not  know 
adjustment  sensitivity,  which  varies  dramatically. 
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Start  Point 


Figure  4-5.  Original  Path  to  Goal  and  Line-Of-Sight  Path 
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Goal  Point 
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Facet  #5 


Second  Attempt 
Path 

(missed  facet  #5) 


Figure  4-7.  Ray  Adjustment  Into  Final  Volume 


Figure  4-8.  Final  Random-Ray  Adjustment  Onto  Goal  Point 


31 


One  problem  encountered  during  the  adjustment  through  the  facets  is 
depicted  in  Figure  4-9.  The  problem  arises  when  passing  from  a  high  to  a  low 
probability-of-detection  where  a  reflection  can  occur.  Table  4-2  shows  die  allowable 


angle  deviation  from  the 
normal  to  the  facet  that  an 


TABLE  4-2.  Tolerance  to  Avoid  Reflection 


inbound  line  to  a  facet  can 
have  and  still  pass  through 
the  facet  according  to  Snell’s 
Law.  If  an  adjustment  of  the 
inbound  ray  puts  its  angle 
deviation  from  the  normal 
outside  this  tolerance,  our 
adjustment  algorithm  will  not 
work.  A  different  approach 


First 

Second 

Maximum 

Maximum 

Volume 

Volume 

Angle  off 

Angle  off 

PD 

PD 

Facet  (rad) 

Facet  (deg) 

0.010 

0.010 

1.5708 

90.0000 

0.015 

0.010 

0.7297 

41.8103 

0.020 

0.010 

0.5236 

30.0000 

0.025 

0.010 

0.4115 

23.5782 

0.030 

0.010 

0.3398 

19.4712 

0.035 

0.010 

0.2898 

16.6016 

0.040 

0.010 

0.2527 

14.4775 

0.045 

0.010 

0.2241 

12.8396 

0.050 

0.010 

0.2014 

11.5370 

0.055 

0.010 

0.1828 

10.4757 

0.060 

0.010 

0.1674 

9.5941 

0.065 

0.010 

0.1545 

8.8499 

0.070 

0.010 

0.1433 

8.2132 

0.075 

0.010 

0.1337 

7.6623 

0.080 

0.010 

0.1253 

7.1808 

0.085 

0.010 

0.1179 

6.7563 

0.090 

0.010 

0.1113 

6.3794 

0.095 

0.010 

0.1055 

6.0423 

was  taken  so  that  once  the 


facet  had  been  intersected. 


but  a  reflection  resulted,  we  change  the  adjustment  vector  to  adjust  to  the  projection 
of  the  last  turn  point  on  the  facet. 

When  the  random  ray  that  hits  the  goal  point  has  been  found,  it  is  passed 
with  the  original  path  to  the  REVISE-PATH  module,  to  fill  in  details  of  the  new 
path  starting  with  this  random-ray.  This  process  is  completed  by  making  the  Snell’s 
Law  adjustment  at  each  successive  facet  until  the  goal  is  reached.  The  points  of 
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Volume  Sequence  for  Path  is  -  VI,  V4,  V3 


Figure  4-9.  Over-Shoot  Corrections 


intersection  of  lines  and  facets  are  used  to  construct  the  new  lines  to  the  goal  and 
both  replace  the  old  lines  and  points  in  the  original  path. 

C.  DISPLAY 

1.  System  Requirements 

The  system  used  to  implement  a  display  was  the  Silicon  Graphics  IRIS 
4D/70GT  with  eight  megabytes  of  memory.  The  features  of  this  machine  such  as 
drawing  routines  implemented  in  hardware,  hidden-line  removal,  and  lighting  and 
shading  routines  made  it  an  ideal  choice.  The  machine  is  UNIX-based  with  the 
program  written  in  C. 

2.  Input  Files 

The  program  reads  in  two  files  with  the  first  being  the  terrain  data  (as  in 
Table  4-3),  and  the  second  being  a  concatenation  of  all  the  paths  you  wish  to 
display  (as  in  Table  4-4).  The  paths  must  include  the  probability  of  detection  along 
each  segment. 

3.  Program  Display 

The  purpose  of  this  part  of  the  program  was  to  visualize  the  terrain  and 
the  paths  created.  The  full  screen  is  used  to  display  the  terrain  and  the  paths  drawn 
over  it  (Figure  4-10).  The  ground  is  drawn  as  a  series  of  polygons  with  the 
variance  in  color  produced  by  the  lighting  built  into  the  IRIS.  This  reflected  light 
is  a  function  of  the  angle  between  the  polygon’s  normal  vector  and  the  light  source 
using  Lambert’s  Cosine  Law  [Ref.  18].  The  paths  are  colored  according  to  their 
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TABLE  4-4.  Example  Path  Data 


TABLE  4-3.  Example  Terrain  Data 


3 

4 
4 
8 


10.00 

300.00 

-0.00 

0.70 

469.23 

601.54 

-300.00 

0.70 

420.00 

668.00 

-700.00 

0.70 

990.00 

990.00 

-990.00 

0.70 

10.00 

300.00 

-0.00 

0.70 

306.97 

509.09 

-300.00 

0.70 

702.92 

787.87 

-700.00 

0.70 

990.00 

990.00 

-990.00 

0.70 

10.00 

300.00 

-0.00 

0.70 

38.25 

297.16 

-81.26 

0.70 

175.07 

303.45 

-300.00 

0.70 

261.58 

307.29 

-437.44 

0.70 

300.05 

309.00 

-498.56 

0.00 

331.59 

391.86 

-700.00 

0.00 

390.88 

438.18 

-700.00 

0.00 

990.00 

990.00 

-990.00 

0.70 

probability  of  detection  along  each  line 
segment,  varying  from  yellow  to  red  as  low  to 
high  probability.  The  dial  controls. 

Figure  4-11,  allow  for  rotation  (Dial  0),  tilt 
(Dial  1),  and  zoom  (Dial  2)  of  the  model. 
Additional  controls  including  EXIT  are 
provided  by  the  mouse  system. 


7 

4 


0 

300 

-1000 

0 

300 

0 

350 

500 

-300 

350 

500 

-1000 

4 

1000 

300 

0 

650 

500 

-300 

350 

500 

-300 

0 

300 

0 

4 

650 

500 

-1000 

650 

500 

-300 

1000 

300 

0 

1000 

300 

-1000 

4 

350 

500 

-300 

475 

300 

-400 

475 

300 

-1000 

350 

500 

-1000 

4 

350 

500 

-300 

650 

500 

-300 

525 

300 

-400 

475 

300 

-400 

4 

525 

300 

-400 

650 

500 

-300 

650 

500 

-1000 

525 

300 

-1000 

4 

475 

300 

-400 

525 

300 

-400 

525 

300 

-1000 

475 

300 

-1000 

4.  Display  Program  Parts 

The  program  can  be  broken  into  four  main  parts  as  shown  in 
Figure  4-12.  The  first  two  sections,  once  completed,  are  never  repeated.  The 
second  two  sections  are  continuously  updated  and  interact  with  each  other  to  cause 
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Figure  4-12.  Block  Diagram  of  Graphic  Display  Program 
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the  changes  in  the  display.  This  program  was  written  for  the  course  Computer 
Graphics,  where  many  of  the  routines  were  given  in  class  or  in  examples. 

5.  Data  Structures 

Two  separate  data  structures  was  used  for  the  terrain  and  the  paths.  The 
terrain  is  read  in  as  a  series  of  polygons  defined  by  their  three-dimensional  vertices. 
The  paths  are  read  in  as  a  series  of  three  dimensional  points  with  a  probability  of 
detection  associated  with  each.  These  items  are  stored  in  array  form  and  are 
adjusted  and  displayed  each  time  the  viewing  angle  or  position  changes. 

6.  Program  Components 
a.  System  Setup 

All  of  the  following  are  initialized:  global  variables,  the  IRIS 
window  system,  material  and  lighting  models,  and  dial  and  menu  controls.  This 
allows  the  window  system  to  be  opened  and  cleared,  and  sets  all  the  colors  for  the 
polygons  and  properties  of  the  lighting  models.  Movement  of  the  objects  is 
facilitated  by  the  use  of  accumulative  matrices,  so  these  are  initially  set  to  a  unit 
matrix. 


b.  File  Input 

The  two  files  are  read  in  and  processed  one  at  a  time.  The  terrain 
file  is  read  in  two  parts:  the  base,  which  is  read  for  all  terrain,  and  the  ground, 
which  is  unique  to  each  area.  As  each  is  completed,  the  normal  vectors  are 
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computed  and  the  colors  and  lighting  properties  are  assigned  to  each  polygon.  Once 
the  terrain  is  complete,  the  paths  are  read  in  with  no  calculations  required. 

c.  Display  Terrain 

The  initial  data  is  displayed  as  it  was  input,  with  all  the  colors  and 
lighting  adjusted.  At  this  point  no  other  inputs  have  been  received  so  the 
accumulative  matrices  are  still  in  unit  form  and  do  not  effect  the  terrain  displayed. 
Subsequent  displays  will  be  altered  by  the  matrices  as  adjusted  by  dial  inputs. 

d.  Control  Inputs 

The  inputs  from  the  three  dials  are  read  and  queued  for  alteration  of 
the  accumulative  matrices.  Dial  zero  allows  you  to  rotate  the  terrain  display  left 
and  right  as  shown  in  Figure  4-13.  This  rotation  is  about  the  center  vertical  axis 
(Y  on  the  IRIS  and  Z  on  the  TI  Explorer).  Each  rotation  is  from  the  last  displayed 
position  and  is  not  dependent  on  the  dial’s  actual  position.  In  other  words,  you  can 
continuously  rotate  in  one  direction  without  reaching  a  stopping  point.  Dial  one 
changes  your  eye  position  from  ground  level  to  a  position  directly  above  the  terrain. 
This  dial  does  have  limitations  as  shown  in  Figure  4-13.  The  last  input  is  zoom, 
on  dial  two.  This  increases  or  decreases  the  size  of  the  picture.  With  this  you 
must  be  careful  because  you  can  be  looking  at  the  terrain  from  inside  of  it,  and  this 
can  be  confusing. 
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Figure  4-13.  Graphic  Display  Limits 
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V.  RESULTS 


A.  PATH  PLANNING 

1.  Aircraft  Realism 

The  A*  search  at  this  point  does  make  its  decisions  based  on  true  aircraft 
aerodynamics.  The  cost  function  relies  heavily  on  the  amount  of  fuel  burned  and 
how  the  missile  will  react  to  a  path  that  will  climb  for  a  great  deal  of  time.  The 
processing  of  this  data  did  not  significantly  increase  the  processing  time  in  the 
[REF.  1]  A*  search.  It  is  important  to  note  that  contemporary  cruise  missiles  can 
store  only  a  limited  number  of  turn  points,  so  if  these  are  kept  to  a  minimum,  the 
better  off  we  are. 

2.  Resultant  Paths 

Table  5-1  shows  that  random-ray  optimization  does  indeed  produce  a 
more  direct  path  from  start  to  goal.  Table  5-2  shows  time  required  to  obtain 
optimized  paths  with  variable  number  of  volumes,  and  Table  5-3  shows  how  many 
single  optimizations  had  to  be  run  on  a  path  to  obtain  the  same  results  (within 
limits)  as  the  random-ray  optimization. 
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Table  5-1.  Random-Ray  Paths  vs  Original  Paths 


Terrain 

Old-Path 

Distance 

Time 

New-Path 

Distance 

Time 

T-27 

0003 

999.7 

133.3 

0008 

599.9 

80.0 

T-21 

0019 

894.1 

119.1 

0020 

815.0 

108.7 

T-27 

0004 

1481.9 

198.1 

0009 

1012.2 

135.0 

T-27 

0023 

1591.1 

212.1 

0052 

1393.0 

185.7 

TABLE  5-2.  Run-Time  to  obtain  Random-Ray  Paths  vs  Old  Optimized  Paths 


No  of  Volumes  Run  Time(sec)  Run  Time(sec) 


Terrain 

In  Path 

Random-Ray 

Old-Optimize 

T-27 

5 

107 

8 

T-21 

5 

239 

42 

T-25 

11 

270 

* 

T-21 

5 

165 

40 

T-27 

4 

7  4 

*  -  Would  not  optimize 

Table  5-3.  Comparison  of  Old  Optimize  vs  Random-Ray 


Random-Ray 

Number  of 

Cost  After 

Terrain 

Path  Cost 

Optimizations 

Old-Optimize 

T-27 

881.4 

3 

981.5 

T-21 

647.2 

6 

683.7 

T-25 

983.7 

3* 

* 

T-21 

659.1 

6 

675.2 

T-27 

1303.2 

3 

1303.3 

*  -  Started  to 

diverge  after  3rd  optimization  run 
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Figure  5-1  through  5-3  show  the  original  path  and  the  optimized  path 
(the  optimized  path  is  the  straighter  of  the  two)  with  Table  5-4  through  5-6  giving 
the  corresponding  data  on  each.  Figure  5-4  and  Table  5-7  show  that  the  results 
obtained  by  the  computer  can  be  improved  on  but  not  by  much. 
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TABLE  5*4.  Original  and  Random-Ray  Path  Data 


>  (path-data  'Ipath0003l) 


Leg 

Total 

Leg 

Total 

Leg 

Fuel 

Vol 

PD 

Leg 

Point  Time 

(10.0  400.0  910.0) 

Time 

Dist 

Dist 

Fuel 

Remain 

PD 

Cost 

Cost 

0.0 

(420.0  700.0  668.0) 

0.0 

0.0 

0.0 

0.0 

1500 

~ 

67.7 

(420.0  852.5  505.0) 

67.7 

508.0 

508.0 

337.6 

1162.4 

0.020 

135.5 

473.1 

20.3 

(110.0  990.0  450.0) 

88.1 

152.5 

660.5 

100.9 

1061.5 

0.020 

40.7 

141.6 

45.2  133.3 

Total  cost  of  this  path  - 

minimum  PD  cost  -  0.0 

maximum  PD  cost  -  135.5 

average  PD  cost  -  6.3 

840.5207 

>  (path-data  ' Ipath0008l) 

339.1 

840. 

999.7 

.5 

225.8 

835.6 

0.000 

0.0 

225.8 

Leg 

Total 

Leg 

Total 

Leg 

Fuel 

Vol 

PD 

Leg 

Point  Time 

(10.0  400.0  910.0) 

Time 

Dist 

Dist 

Fuel 

Remain 

PD 

Cost 

Cost 

0.0 

(71.3271  700.0  622. 

0.0 

3257) 

0.0 

0.0 

0.0 

1500 

— 

40.8  40.8 

(107.56799  877.03156  452. 

306.2 

3262) 

306.2 

202.8 

1297.2 

0.020 

81.7 

284.5 

24.1 

(110.0  990.0  450.0) 

64 .9 

180.7 

486.9 

119.7 

1177.4 

0.020 

48.2 

167.9 

15.1 

Total  cost  of  this 
minimum  PD  cost  - 
maximum  PD  cost  - 
average  PD  cost  - 

80 .0 
path  - 
0.0 
81.7 
6.6 

113.0 

527. 

599.9 

,7 

75.3 

1102.1 

0.000 

0.0 

75.3 

527.7141 
>  (dribble) 


Figure  5-2.  Original  vs  Random-R:  Optimized  Paths 


TABLE  5-5.  Original  and  Random-Ray  Path  Data 


>  (path-data  'Ipath0019|) 

Leg  Total  Leg 

Total 

Leg 

Fuel 

Vol 

PD 

Leg 

Point  Time  Time  Dist 

Dist 

Fuel 

Remain 

PD 

Cost 

Cost 

(500.0  200.0  600.0) 

0.0  0.0  0.0 

0.0 

0.0 

1500 

_ 

_ 

_ 

(500.0  300.0  700.0) 

13.3  13.3  100.0 

100.0 

67.1 

1432.9 

0.015 

20.0 

87.1 

(500.0  700.0  700.0) 

53.3  66.7  400.0 

500.0 

266.7 

1166.2 

0.015 

80.0 

346.7 

(500.0  850.0  500.67114) 

20.0  86.7  150.0 

650.0 

99.1 

1067.1 

0.015 

30.0 

129.1 

(300.0  990.0  440.0) 

32.6  119.2  244.1 

894.1 

162.5 

904 .6 

0.000 

0.0 

162.5 

Total  cost  of  this  path  -  725, 

minimum  PD  cost  -  0.0 

maximum  PD  cost  -  80.0 

average  PD  cost  -  6.1 

725.37067 

> 

>  (path-data  ’Ipath0020l) 

Leg  Total  Leg 

.4 

Total 

Leg 

Fuel 

Vol 

PD 

Leg 

Point  Time  Time  Dist 

Dist 

Fuel 

Remain 

PD 

Cost 

Cost 

(500.0  200.0  600.0) 

0.0  0.0  0.0 

0.0 

0.0 

1500 

_ 

__ 

_ 

(474.61185  305.07764  563.2685) 
14.4  14.4  108.1 

108.1 

71.9 

1428.1 

0.015 

21.6 

93.5 

(384.7632  676.95264  433.27493) 
51.0  65.4  382.6 

4  90.7 

254.5 

1173.6 

0.015 

76.5 

331.0 

(377.15268  708.35095  422.09427) 
4.3  69.7  32.3 

523.0 

21.5 

1152.1 

0.015 

6.5 

27 . 9 

(300.0  990. C  440.0) 

38.9  108.7  292.0 

815.0 

194  .8 

957.4 

0.000 

0.0 

194.8 

Total  cost  of  this  path  -  647. 

minimum  PD  cost  -  0.0 

maximum  PD  cost  -  76.5 

average  PD  cost  -  6.0 

,2 

647.21844 
>  (dribble) 
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Figure  5-3.  Original  vs  Random-Ray  Optimized  Paths 


i 

i 

[ 


TABLE  5-6.  Original  and  Random-Ray  Path  Data 


>  (path-data  'Ipath0023l) 
Leg  Total 

Leg 

Total 

Leg 

Fuel 

Vol 

PD 

Leg 

Point  Time  Time 

Dist 

Dist 

Fuel 

Remain 

PD 

Cost 

Cost 

(10.0  0.0  300.0) 

0.0  0.0 

0.0 

0.0 

0.0 

1500 

_ 

_ 

_ 

(469.23077  300.0  601.53845) 

73.1  73.1  548.5 

548.5 

367.0 

1133.0 

0.020 

146.3 

513.3 

(420.0  700.0  668.0) 

53.7  126.9 

403.0 

951.6 

269.0 

864 .0 

0.020 

107.5 

376.4 

(990.0  990.0  990.0) 

85.3  212.1 

639.5 

1591.1 

427.8 

436.2 

0.020 

170.5 

598.3 

Total  cost  of  this  path  - 

minimum  PD  cost  -  107.5 

maximum  PD  cost  -  170.5 

average  PD  cost  -  7.0 

1488.1104 

> 

> 

>  (path-data  'Ipath0052l) 
Leg  Total 

1488. 

Leg 

,1 

Total 

Leg 

Fuel 

Vol 

PD 

Leg 

Point  Time  Time 

Dist 

Dist 

Fuel 

Remain 

PD 

Cost 

Cost 

(10.0  0.0  300.0) 

0.0  0.0 

0.0 

0.0 

0.0 

1500 

_ 

_ 

_ 

(306.9697  300.0  509.0909) 
56.3  56.3 

422.1 

422.1 

282.4 

1217.6 

0.020 

112.6 

394 .9 

(702.92303  700.0  787.8744) 
75.0  131.3 

562.8 

985.0 

376.5 

841.2 

0.020 

150.1 

526.6 

(990.0  990.0  990.0) 

54.4  185.7 

408.1 

1393.0 

272.9 

568.2 

0.020 

108.8 

381.8 

Total  cost  of  this  path  - 
minimum  PD  cost  -  108.8 
maximum  PD  cost  -  150.1 
average  PD  cost  -  7.0 

1303. 

,2 

1303.2467 

> 

> 

>  (dribble) 
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TABLE  5-7.  Computer  Optimized  vs  User  Optimized 


>  (path-data  'Ipath0029|) 


Leg  Total  Leg 

Total 

Leg 

Fuel 

Vol 

PD 

Leg 

Point  Time  Time  Dist 

(410.0  10.0  900.0) 

Dist 

Fuel 

Remain 

PD 

Cost 

Cost 

0.0  0.0  0.0 
(550.05664  300.0  633.2163) 

0.0 

0.0 

1500 

— 

— 

42.9  42.9  322.0 

(660.2497  528.16956  423.31775) 

322.0 

213.5 

1286.5 

0.020 

85.9 

299.4 

33.8  76.7  253.4 

(741.65796  700.0  411.26544) 

575.4 

168.0 

1118.5 

0.020 

67.6 

235.6 

25.4  102.1  190.1 

(900.0  990.0  300.0) 

765.6 

126.7 

991.8 

0.000 

0.0 

126.7 

44.1  146.1  330.4 

Total  cost  of  this  path  -  881, 

minimum  PD  cost  -  0.0 

maximum  PD  cost  -  85.9 

average  PD  cost  -  6.0 

881.4159 

>  (path-data  'Ipath0037|) 

1096.0 

,4 

219.8 

772.0 

0.000 

0.0 

219.8 

Leg  Total  Leg 

Total 

Leg 

Fuel 

Vol 

PD 

Leg 

Point  Time  Time  Dist 

(410.0  10.0  900.0) 

Dist 

Fuel 

Remain 

PD 

Cost 

Cost 

C.O  0.0  0.0 

(556.0  300.0  601.0) 

0.0 

0.0 

1500 

- 

- 

- 

43.3  43.3  324.7 

(650.91486  491.0918  406.6197) 

324  .7 

215.1 

1284.9 

0.020 

86.6 

301.7 

28.4  71.7  213.4 

(754.3238  700.0  353.66742) 

538.0 

141.4 

1143.5 

0.020 

56.9 

198.3 

31.1  102.8  233.1 

(900.0  990.0  300.0) 

771.1 

155.2 

988.4 

0.000 

0.0 

155.2 

43.3  146.1  324.5 
Total  cost  of  this  path  -  871. 
minimum  PD  cost  -  0.0 

1095.7 

2 

216.1 

772.2 

0.000 

0.0 

216.1 

maximum  PD  cost  -  86.6 
average  PD  cost  -  6.0 

871.23987 
>  (dribble) 
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B.  DISPLAY 


1.  Terrain  Models 

Because  transparent  three-dimensional  line  drawings  of  terrain  are 
acceptable  only  to  the  trained  eye,  a  display  that  uses  solid  figures  and  hidden  line 
removal  is  much  preferred.  Figure  5-5  through  5-7  show  the  contrast  in 
understandability  of  the  line  drawings  versus  graphic  depiction.  As  the  models 
become  even  more  complex  the  need  for  better  displays  increases.  Figure  5-8 
through  5-10  show  how  adding  multiple  paths  has  little  effect  on  the  readability. 
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Figure  5-5.  Line  Drawing  vs  Graphic  Display 


Figure  5-6.  Line  Drawing  vs  Graphic  Display 
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Figure  5-7.  Line  Drawing  vs  Graphic  Display 
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Figure  5-10.  Line  Drawing  vs  Graphic  Display  (Multi-Path) 


2.  Viewpoint  and  Perspective 

Using  the  graphics  display  we  are  able  to  place  ourself  at  the  location  of 
the  observer  and  see  what  he  might  see  (Figure  5-11)  or  view  the  path  from  any 
angle,  as  shown  previously.  This  is  a  great  advantage  when  making  the  final 
decision  on  which  path  is  best. 


Figure  5-11.  View  From  Observer  Position 
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VI.  CONCLUSIONS 


A.  DISCUSSION 

All  goals  set  at  the  beginning  of  this  project  have  been  met:  to  modify  [Ref. 

1]  to  include  a  more  aerodynamic  model,  to  graphically  display  our  model,  and  to 
implement  a  new  optimization  technique.  The  flight  characteristics  of  most  Navy 
aircraft  can  be  modeled  and  encoded  in  the  aircraft  section  of  the  program.  This 
data  can  be  extracted  from  the  various  NATOPS  manuals  for  the  aircraft  or  obtained 
from  Naval  Labs. 

The  graphic  display  was  developed  to  confirm  that  a  three-dimensional  display 
was  possible  and  was  useful  in  showing  the  optimality  of  our  best  path.  The 
jetcard  type  printouts  are  helpful  for  the  actual  figures  such  as  time  and  fuel  used, 
but  to  get  a  full  feeling  of  the  path,  the  graphic  display  is  a  must. 

The  advantage  of  our  method  of  optimization  is  the  speed  at  which  a  solution 
can  be  obtained.  As  shown  in  Chapter  V,  the  random-ray  method  eliminates  the 
vast  majority  of  paths  to  explore  and  optimize.  The  optimization  is  obtained  in  one 
pass  so  no  further  calculations  are  required  to  see  if  a  better  path  exists.  If  no 
random-ray  optimization  path  exists,  we  are  no  worst  off  then  we  were  to  begin 
with,  so  we  can  use  the  approach  of  [Ref.  1]  to  optimize  each  path  individually. 
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B.  KNOWN  PROBLEMS 


There  is  no  treatment  of  the  paths  around  obstacles  by  the  random-ray 
technique.  Choices  need  to  be  made  as  to  how  to  detour  around  objects.  Presently, 
if  Snell’s  Law  cannot  bend  the  path  to  avoid  the  object,  it  says  no  path  is  available. 

The  observers  we  have  modeled  have  unlimited  line-of-sight  capabilities,  not 
affected  by  the  range  limitations.  Such  details  can  be  added  to  the  program  as  well 
as  adjustments  for  diffusion,  diffraction,  and  refraction. 

No  attempt  was  made  to  allow  for  weighting  of  optimization  criteria.  The 
main  criteria  can  remain  minimal  detection,  but  a  choice  can  be  made  whether  to 
maximize  fuel  utilization  or  time.  Items  such  as  aircraft  speed,  altitude  and  fuel 
load  can  also  be  weighted. 

The  graphic  display  runs  separately  and  addresses  only  our  limited  models  of 
terrain.  The  program  needs  to  be  expanded  to  allow  altering  the  paths  displayed 
while  the  program  is  running,  and  to  display  larger  areas  of  terrain  and  real  terrain 
data  such  as  in  [Ref.  8], 

Elements  that  affect  aircraft  and  aircrew  performance  have  not  been  included. 
Items  like  temperature,  winds  and  severe  weather  could  be  included  as  properties  of 
each  volume.  Variations  in  altitude  and  speed,  for  changes  in  visibility  conditions, 
terrain  type  (mountainous,  hilly  or  flat),  and  aircrew  ability  need  to  be  addressed. 

As  discussed  in  chapter  IV,  Snell’s  Law  is  very  susceptible  to  reflection  if  the 
danger  (probability-of-detection)  varies  much  from  volume  to  volume.  This  can  be 
avoided  by  standardizing  the  values  for  probability-of-detection  so  that  the  maximum 
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is  no  more  then  0.05.  Note  that  a  volume  that  is  not  visible  is  automatically  given 
a  value  of  0.01  to  avoid  a  division-by-zero  error. 

C.  RECOMMENDATIONS 

Execution  time  is  going  to  be  significant  no  matter  what  machine  the  program 
is  implemented  on.  If  we  can  store  the  results  of  the  division  of  airspace  into 
volumes,  we  can  do  only  once  the  initial  processing,  the  most  time-intensive  phase, 
and  use  the  stored  data  from  then  on.  Because  of  the  way  labels  are  generated  by 
the  TI  Explorer  for  the  objects  we  use  (points,  lines,  facets,  volumes,  and  so  on,), 
we  are  limited  to  9999  of  each  type.  When  random-ray  optimization  is  run,  many 
labels  generated  are  not  used  more  then  once,  which  depletes  the  list  after  only  a 
limited  number  of  paths  have  been  tested.  This  should  be  fixed. 

Another  optimization  technique  which  can  be  implemented  is  to  restrict  the  set 
of  directions  before  the  selection  of  the  random  ray.  This  was  demonstrated  in  two 
dimensions  by  Ron  Ross  [Ref.  19].  To  do  this,  find  the  range  of  all  possible  rays 
that  will  pass  through  the  first  window  from  the  start  point.  As  these  rays  pass 
through  the  window,  apply  Snell’s  Law  and  see  which  of  these  pass  through  the 
second  window.  The  rays  not  passing  through  the  second  window  can  now  be 
eliminated  from  the  original  set  of  directions.  This  can  be  continued  until  the  goal 
is  reached  or  until  no  rays  pass  through  the  next  window. 
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APPENDIX  A 


This  Appendix  contains  a  listing  of  the  following  files: 


aircraft-controls. lisp 
common-functions  .lisp 
interceptlisp 
path-data,  lisp 
path-planning.lisp 
visibUity.lisp 
test-cases.lisp 


camera.lisp 
improved-camera.lisp 
kinematics,  lisp 
path-optimization.lisp 
setup.lisp 

volume-functions.lisp 

testdisp 


Instructions  for  running  programs: 

1.  Input  terrain  with:  (set-up  1  ’t27-ridges-shadow)  or  (set-up  2  't3 10-full-ridge) 


depending  on  the  form  of  the  terrain  file  (type  1  or  2). 

2.  Initialize  the  observers  with  (init-observer  ’(10  500  250)  ’0.02). 

3.  Type  (set-up-2)  to  divide  volumes  by  visibility. 

4.  Do  search  with: 

(a-star-search  (init-point  '(0  0  200))  (init-point  ’(0  1000  200))  ’nil  ’t)) 


or 

(a-star-search-m  (init-point  ’(0  0  200))  (init-point  ’(0  1000  200))  'nil  5  ’l)) 

5.  Optimize  a  path  with:  (optimize -path  ’/path0002/)  or  (random-ray-optimize 
’(/path0002/)). 

6.  To  see  the  data  on  a  path  type  (path-data  ’/path0002/). 

7.  To  send  the  data  on  a  path  to  a  file  for  the  IRIS  type  (path-for-iris 
’  Ipath0002l). 
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;;  Mode : Common -Lisp;  Base: 10 

*************************************************************************** 


AIRCRAFT  CONTROL  L.R.  MRENN  6  Mar  89 


Contains  the  functions  nessesary  to  aircraft  performance.  Can  be  altered 
depending  on  the  type  aircraft  needed  and  ita  performance  spec.  The 
current  aircraft  is  a  fictional  model  with  the  following  spec: 

gross  wt.  2525  lbs.  [include  full  fuel] 

desired  cruise  speed  450  Kts 

Fuel  Flow  <FF)  Straight  and  level  avg.  300  lbs/hour 

limits  on  climb/dive  with  out  gaining  or  loosing  speed: 

-10  deg  FF  -  80  lbs 
20  deg  FF  -  900  lbs 

*************************************************************************** 

*********************************************************************** 

Aircraft  controls  routines 

*********************************************************************** 

takes  as  input  the  actual  distance  aircraft  will  travel 

[not  ground  distance] 

climb  angle  in  degrees,  fuel  -  what  you  start  with, 

TAS  -  start  with. 

{defun  fuel-burned  (distance  climb-angle  fuel  TAS) 

(let  ((FF  '0) 

(original-TAS  TAS) 

(climb-angle  (rational  climb-angle)) 

(fuel-used) 

(time  '0)) 

(cond  ( (LT  climb-angle  -10)  ;climb  angle  less  than  10  deg 

(so tf  climb-angle  '-10) 

(setf  *TAS*  '450) 

(setf  time  (*  (/  distance  tas)  60)) 

(setf  FF  80) 

(setf  *fuel*  (-  fuel  <*  FF  (/  time  60)))) 

(setf  fuel-used  (*  FF  (/  time  60))) 
fuel-used) 

( (GT  climb-angle  20)  ; climb  angle  greater 

;  than  20  deg 

(setf  TAS  (get-new-TAS  distance  climb-angle  TAS)) 

(setf  time  (/  distance  (/  (/  (+  original-TAS  TAS)  2)  60))) 

(setf  FF  900) 

(setf  *fuel*  (-  fuel  (*  FF  (/  time  60)))) 

(setf  fuel-used  (*  FF  (/  time  60))) 
fuel-used) 

(t  /climb  angle  >-  -10  and  <*>  20 

(setf  *TAS*  '450) 

(setf  time  (*  (/  distance  tas)  60)) 

(setf  FF  (+  300 

<*  21.409090  climb-angle) 

(*  .1037878  (expt  climb-angle  2)) 

(*  .01628787  (expt  climb-angle  3)))) 

(setf  ‘fuel*  (-  fuel  (*  FF  (/  time  60)))) 

(setf  fuel-used  (*  FF  (/  time  60))) 
fuel-used) 

)  )  ) 
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;  using  decal  rate  of  3kts/degree>20/min  find  the  new  TAS 

;  will  return  new-TAS  or  will  stop  if  TAS  goes  below  0  and  return  neg  number 
(defun  get-new-TAS  (dist  climb-angle  TAS) 

(do*  ((old-time  '0  new-time) 

(original -TAS  TAS) 

(TAS  TAS  New-TAS) 

(new-time  (/  dist  (/  original-TAS  60)) 

(/  dist  (/  (/  (+  original-TAS  new-TAS)  2)  60))) 

(new-TAS  (-  original-TAS  (*  (*  3  (-  climb-angle  20))  new-time)) 

(-  original-TAS  (*  (*  3  (-  climb-angle  20))  new-time)))) 

((or  (LT  (-  new-time  old-time)  '0.05)  (LT  new-TAS  '0))  new-tas) ) ) 


(defun  tl  (climb-angle) 


;  Test  function  used  to 
;  test  fuel-used  funation 


(let ((distance  '450) 

(fuel  *fuel*) 

(tas  *tas») 

(time  '0) 

(fuel-used  '0)) 

(princ  distance) (terpri) 

(princ  climb-angle) (terpri) 

(princ  fuel) (terpri) 

(princ  time) (terpri) 

(princ  fuel-used) (terpri) (terpri) 

(setf  fuel-used  (fuel-burned  distance  climb-angle  fuel  TAS)) 
(princ  distance) (terpri) 

(princ  climb-angle) (terpri) 

(princ  fuel) (terpri) 

(princ  time) (terpri) 

(princ  fuel-used) (terpri) (terpri) 

)) 
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;;;  Mode:  LISP;  Syntax:  Common-lisp 

**************************************************************************** 

}  7  7 

;;;  FLAVORS  FOR  3-D  DISPLAY  OF  VOLUMES  /Written  by  Dr  Sehung  Kwak 

;t;  /for  CS4452 

sss  THESIS  D.H.  Lewis  18  May  1988 

r  *  t 

■A************************************************************************** 

(defflavor  Graphic 
(node-list 
polygon-list 
transformed-node-list 
H -matrix) 

0 

: inittable-instanoe-variables 
: settable-instance-variables 
:gettable-instance-variables 
: outside-aocesaible-in stance -variables) 

(defmethod  (Graphic  :translate-and-euler-angle-transform) 

(x  y  z  azimuth  elevation  roll) 

(let  () 

(sett  H-matrix 

(homogeneous-transform  azimuth  elevation  roll  x  y  z) ) 

(setf  transformed-node-list 
(mapcar  #' (lambda  (node-location) 

(post-multiply  H-matrix  node-location) ) 
node-list) ) ) ) 

(defmethod  (graphic  : get -node-polygon-list)  () 

(list  transformed-node-list  polygon-list)) 

(defmethod  (graphic  /initialize)  () 

(setf  node-list  (send  self  :make-node-list) ) 

(setf  polygon-list  (send  self  :make-polygon-list) ) 

(setf  transformed-node-list  node-list) 

(setf  H-matrix  (unit -matrix  4))) 

(defmethod  (graphic  : get -transformed-node-list)  () 
transformed-node-list) 

*************************************************************************** 

•  • 
f  / 

;;  CAMERA  FLAVOR  AND  METHODS  TO  USE  GRAPHIC  FLAVOR 

;;  /Written  by  Dr  Sehung  Kwak 

;;  z for  CS4452 

f  f 

;;  THESIS  D.H.  Lewis  10  May  1988 

*************************************************************************** 

(defflavor  camera 
(H-matrix 
image -distance 
previous-point 
*camerwindow* 
scale) 

() 

: initable-instance-var iablea 
: get table- instance-variables 

/outside -accessible- instance-variables) 


69 


(defmethod  (camera  : initialize) 

() 

(setf  H-matrix  (unit-matrix  4)) 

(aetf  image-distance  *image-diatanoe*) 

(setf  scale  *scale*) 

(setf  *camer window* 

(tvsmake-window  'tvswindow 
:blinker-p  nil 

{position  *window-upper- left-corner* 

: inside-width  *window-width* 

: inside-height  *window-height* 

:nane  "VOLUME  WINDOW” 

: save-bits  t 
:expose-p  t) ) ) 

(defmethod  (camera  : initialize-B)  ;  for  advanced  functions 

(window-stats ) 

(setf  H-matrix  (unit-matrix  4)) 

(setf  image-distance  *image-distance*) 

(setf  scale  *scale*) 

(setf  *caunerwindow* 

(tvimake-window  'tv:window 
:blinker-p  nil 

{position  (list  (first  window-stats) 

(second  window-stats)) 
i inside-width  (third  window-stats) 
i inside-height  (fourth  window-atats) 

{name  (fifth  window-stats) 

{ save-bits  t 
:expoae-p  t) ) ) 

(defmethod  (camera  {move) 

(x  y  z  azimuth  elevation  roll) 

(setf  H-matrix  (matrix-inverse 

(homogeneous-transform  azimuth  elevation  roll  x  y  z)))) 


(defmethod  (camera  : take-picture) 

(solid-object) 

(let*  ( (node-polygon-list 

(send  (aval  solid-object)  {get-node-polygon-list) ) 

(node-vector  (send  self  :convert-list-of-lists-to-vector 
(first  node-polygon-list) ) ) 

(polygon-list  (second  node-polygon-list))) 

;  (send  *camerwindow*  {refresh)  ;  don't  need  for  multiple  shots 

(dolist  (polygon  polygon-list) 

(send  self  {draw-polygon  polygon  node-vector ) ) ) ) 


(defmethod  (camera  {draw-polygon) 

(polygon  node-vector) 

(let  (  (first-point  (first  polygon) ) 

(rest-points  (edr  polygon) ) ) 

(send  self  {move-pen  (elt  node-vector  first-point) ) 
(dolist  (point  rest-points) 

(send  self  :draw-line  (elt  node-vector  point))) 

(send  self  {draw-line  (elt  node-vector  fir at -point) )) ) 
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(defmethod  (camera  : move -pen) 

(point) 

(setf  previous -point  (send  self  : screen-transform  point) ) ) 


(dafmethod  (camera  : draw-line) 

(next -point) 

(let  ((current-point  (send  self  : screen-transform  next-point))) 
(send  self  : draw-line-on-screen  previous -point  current -point) 
(setf  previous -point  current -point) ) ) 


(defmethod  (camera  : draw-line-on-acreen) 
(from-point  to-point) 

(send  *camerwindow*  : draw-line 

(first  from-point)  (second  from-point) 
(first  to-point)  (second  to-point) 
♦thickness*) ) 


(defmethod  (camera  :convert-list-of-liata-to-vector) 
(list-of-lists) 

(oval  (cons  ' vector 

(mapear  ' (lambda  (component-list) 

(cons  'list  component-list) ) 
list-of-lists) ) ) ) 


(defmethod  (camera  : screen-transform) 

(point) 

(let*  ( (point-on-camerspace 
(post-multiply 
H-matrix  point) ) 

(x  (first  point-on-camerspace) ) 

(y  (second  point-on-camerspace) ) 

(z  (third  point-on-camerspace))) 

(cond  ((equal  0.0  z)  (setf  z  0.00001)) 

(t)  ) 

(list  (+  (round  (*  scale  (/  (*  image-distance  x)  (-  z) ) ) ) 
(/  ‘window-width*  2)) 

(-  (/  ‘window-height*  2) 

(round  (*  scale  (/  (*  image-distance  y)  (-  z))  )))))) 


(defmethod  (camera  : kill-camera-window) 

() 

(send  ‘camerwindow*  :kill)  ) 


(defun  take-picture  (Camera  List-of-ob jects) 

(send  (eval  Camera)  : initialize) 

(send  (eval  Camera)  .-move  '2000  '2000  '2000  '0  '0.5  '0.75) 

(loop  for  V  in  List-of-ob jects 
:initialize) 

do  (send  (eval  V)  :tranalate-and-euler-angle-transform  ' -2500 
-2000  '0.6  '0.6  '-0.1) 
amera)  : take-picture  V))) 


do 

(send 

(eval 

do 

(send 

(eval 

t 

-2000 

do 

(send 

(eval 
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advanced  camera  functions 


D.H.  Lewis 


(defvar  ‘window-width*  700) 

(defvar  ‘window-height*  400) 

(defvar  ‘window-upper-left-corner*  '(10  10)) 

(defvar  ‘scale*  5) 

(defvar  * image-distance*  120) 

(defvar  ‘thickness*  '5)  ;  line  thickness,  in  pixels 


(defvar  ‘ideal*) 

(defvar  *low-left-front*) 
(defvar  *high-left-front*) 
(defvar  *low-right-front*) 
(defvar  ‘right-side* ) 
(defvar  *left-rear-3/4*) 
(defvar  *top*) 

(defvar  *display-stats*) 
(defvar  *nikon-l*) 

(defvar  *nikon-2*) 

(defvar  *nikon-3*) 

(defvar  *nikon-4*) 

(defvar  *nikon-5*) 

(defvar  *nikon-6*) 

(defvar  *list-of-cameras*) 
(defvar  ‘window-stats* ) 


(defun  make-cameras  () 

(setf  *nikon-l*  (make-instance  'camera)) 

(setf  *nikon-2*  (make-instance  'camera)) 

(setf  *nikon-3*  (make-instance  'camera)) 

(setf  *nikon-4*  (make-instance  'camera)) 

(setf  *nikon-5*  (make-instance  'camera)) 

(setf  *list-of-cameras* 

' (*nikon-l*  *nikon-2*  *nikon-3*  *nikon-4*  *nikon-5*) ) 

(setf 

•ideal* 

'(7500.0  3500.0  6200.0  2.0  0.0  0.9800  -500.0  -500.0  200.0  0.0  0.0  0.0)) 
(setf 

*low-left-front* 

'(100.0  200.0  4000.0  0.0  0.50  1.0  1.0  1.0  -1.5  0.0  0.0  0.0)) 

(setf 

‘high- left -front* 

'(3725.0  -11900.0  5950.0  0.25  0.10  1.17  -500.0  -500.0  200.0  0.0  0.0  0.0)) 
(setf 

*low-right-f ront * 

'(100.0  100.0  4000.0  0.0  0.5  1.5  1.0  1.0  1.0  0.0  0.0  0.0)) 

(setf 

•right-side* 

'(00.0  -4000.0  1500.0  0.0  0.0  01.40  -500.0  -500.0  200.0  0.0  0.0  0.0)) 
(setf 

*lef t-rear-3/4  * 

'(-500.0  0.0  4000.0  0.0  0.0  1.0  1.0  1.0  1.0  0.0  0.0  0.0)) 

(setf 

*top* 

'(0.0  0.0  4000.0  0.0  0.0  0.0  -500.0  -500.0  200.0  0.0  0.0  0.0)) 

'nil) 
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■MAIN  FOUR  WINDOW  DISPLAY 


(defun  display  ()  ;ex.  (display) 

(setf  *window-stata*  '  ('nil 

(10  20  700  400  "air-volumes’’  20  140) 

(10  440  200  200  "top-view:  ground"  7  60) 

(260  440  200  200  "same-view:  ground"  20  60) 

(510  440  200  200  "full-view:  ground"  15  60))) 

(setf  "display-stats*  (list  'nil 

♦high-left-front * 

♦top* 

♦high-left-front* 

♦ideal*) ) 

(let  ((air-volumes  'nil) 

(ground-volumes  'nil) 

(objects  'nil)) 

(loop  for  V  in  (universe-volumes  *universe*) 
do  (cond  ((equal  'ground  (volume-composition  (eval  V))) 

(setf  ground-volumes  (adjoin  V  ground-volumes) ) ) 

(t  (setf  air-volumes  (adjoin  V  air-volumes) ) ) ) ) 

(loop  for  Obs  in  (universe-observers  ‘universe*) 

do  (setf  ground-volumes  (adjoin  Obs  ground-volumes)) 
do  (setf  air-volumes  (adjoin  Obs  air-volumes) ) ) 

(setf 

objects 

(list  'nil  air-volumes  ground-volumes  ground-volumes  ground- volumes) ) 
(loop  for  N  in  ' (1  2  3  4) 

do  (take-picture-4  (nth  N  *list-of -cameras*) 

(nth  N  *window-stats*) 

(nth  N  objects) 

(nth  N  *display-stats*) ) ) ) 


'  nil ) 


; - DISPLAY  GROUND  IN  (2  WINDOWS) - 

(deftin  display-ground  ()  ;ex.  (display-ground) 

(setf  *window-atats*  '('nil 

(10  20  600  380  "Path-over-ground”  15  140) 

(10  420  600  290  "Alternate-view  "  20  140) 
('nil) 

('nil)  )  ) 

(setf  *display-stats*  (list  'nil 
♦ideal* 

♦high- left -front  * 

'nil  ;*top* 

'nil))  ? *right-side* ) ) 

(let  ((objects  'nil) 

(ground-volumes  'nil)) 

(loop  for  V  in  (universe-volumes  ‘universe*) 

do  (cond  ((equal  'ground  (volume-composition  (eval  V)  ) ) 
(setf  ground-volumes  (adjoin  V  ground-volumes))))) 
(setf  ground-volumes 

(append  (universe-observers  ‘universe*)  ground-volumes)) 
(setf  objects  (list  'nil 

ground-volumes 

ground-volumes 

'nil 

'nil)) 

(loop  for  N  in  ' (1  2  ) 

do  (take-picture-4  (nth  N  *list-of-cameras*) 

(nth  N  *window-stats* ) 
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(nth  N  objects) 

(nth  N  *diaplay-atata*) ) ) ) 


'nil) 


; - DISPLAY  VISIBLE  AIR  VOLUMES  (3  WINDOWS) - 

(defun  display-viaibla  (obaarvar)  jax.  (display-visible  ' | obaarva0002 | ) 
(aetf  *window-stata*  '('nil 

(10  20  700  400  "viaible-air-volumes"  20  140) 

'nil 

(260  440  200  200  "same-view-ground"  20  60) 

<510  440  200  200  "full- view-ground"  15  60))) 

(aetf  *diaplay-atata*  (liat  'nil 

♦high- left -front * 

'nil 

♦high-left-front  * 

♦ideal*  )) 

(let  ((visible-volumes  'nil) 

(ground-volumes  'nil) 

(objects  'nil)) 

(loop  for  V  in  (universe-volumes  'universe*) 
do  (cond  ((equal  'ground  (volume-composition  (aval  V))) 

(setf  ground-volumes  (adjoin  V  ground-volumes) ) 

(setf  visible-volumes  (adjoin  V  visible-volumes))) 

( (member-p  observer  (volume-visibility  (aval  V) ) ) 

(setf  visible-volumes  (adjoin  V  visible-volumes) ) ) ) ) 

(loop  for  Obs  in  (universe-observers  ‘universe*) 

do  (setf  ground-volumes  (adjoin  Obs  ground-volumes)) 
do  (setf  visible-volumes  (adjoin  Obs  visible-volumes) ) ) 

(setf  objects  (list  'nil  visible-volumes 

'nil  ground-volumes  ground- volumes) ) 

(loop  for  N  in  '  <1  3  4) 

do  (take-picture-4  (nth  N  *list-of-eameras*) 

(nth  N  *window-stats*) 

(nth  N  objects) 

(nth  N  *display-stats*) ) ) ) 

'nil) 


- - DISPLAY  NON  VISIBLE  AIR  VOLUMES  (3  WINDOWS) - 

(defun  display-not -visible  (observer) 

;ex.  (display-not-viaible  ' ( observe0002 | ) 
(setf  *window-stats*  '('nil 

(10  20  700  400  "non -visible -air-volumes"  20  140) 

'  nil 

(260  440  200  200  "same-view-ground"  20  60) 

<510  440  200  200  "full-view-ground"  15  60))) 

(setf  *display-stats*  (list  'nil 

♦high- left-front* 

'  nil 

♦high- left -front* 

♦ideal*  )) 

(let  ((invisible-volumes  ’nil) 

(ground- volumes  'nil) 

(objects  ' nil) ) 


74 


(loop  for  V  in  (universe-volumes  ‘universe*) 

do  (oond  ( (equal  'ground  (volume-composition  (aval  V))) 

(aatf  ground-volumes  (adjoin  V  ground- volumes) ) 

(setf  invisible-volumes  (adjoin  V  invisible-volumes) ) ) 

( (not  (member-p  observer  (volume-visibility  (eval  V) ) ) ) 
(setf  invisible-volumes  (adjoin  V  invisible-volumes) ) ) ) ) 
(loop  for  Oba  in  (universe-observers  ‘universe*) 

do  (setf  ground-volumes  (adjoin  Obs  ground-volumes) ) 
do  (setf  invisible-volumes  (adjoin  Obs  invisible-volumes))) 
(setf  objects  (list  'nil  invisible-volumes 

'nil  ground-volumes  ground-volumes)) 

(loop  for  H  in  ' (1  3  4) 

do  (take-picture-4  (nth  N  *list-of-cameras*) 

(nth  N  *window-stata*) 

(nth  N  objects) 

(nth  N  *display-atats*) ) ) ) 

'nil) 


DISPLAY  SELECTED  VOLUMES  AND  THE  GROUND  (2  WINDOWS) 


(defun  display-volumes  (list-of-volumea) 

;ex.  (display-volumes  ' ( | volumeOOOl |  |volume0012|  | volume0015 | ) ) 
(setf  *window-stats*  '('nil 

(10  20  350  300  "desired-volumes"  17  140) 

'  nil 

(510  440  200  200  "f ull-view-ground"  20  60) 

'nil) ) 

(setf  *display-stats*  (list  'nil 

•high-left-front* 

'  nil 


*high-left-f ront * 

'nil)) 

(let  ((objects  'nil) 

(ground-volumes  'nil)) 

(loop  for  V  in  (universe-volumes  ‘universe*) 

do  (cond  ((equal  'ground  (volume-composition  (eval  V) ) ) 
(setf  ground-volumes  (adjoin  V  ground-volumes) ) ) ) ) 
(loop  for  Obs  in  (universe-observers  ‘universe*) 

do  (setf  ground-volumes  (adjoin  Obs  ground-volumes) ) ) 
(setf  objects  (list  'nil 

list -of -volumes 
'  nil 


ground-volumes 
'nil) ) 

(loop  for  N  in  ' (1  3) 

do  (take-picture-4  (nth  N  *list-of-cameras*) 


(nth  N  *window-stats* ) 

(nth  N  objects) 

(nth  N  *diaplay-stats*) ) ) ) 

'nil) 
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■DISPLAY  PATH  AND  GROOND  (3  WINDOWS) 


(defun  display-path  (path-name)  ;ex.  (display-path  '|path0002|) 

(setf  "window-stats*  ' ('nil 

(10  20  600  380  "Path-over-ground"  15  140) 

(10  420  600  290  "Alternate-view  ”  20  140) 

(618  200  200  200  "Top-view"  7  60) 

(618  420  200  200  "Low-side  view"  7  60))) 

(setf  "display-stats*  (list  'nil 

•ideal* 

*high-left-front * 

*top* 

"right-side* ) ) 

(let  ((objects  'nil) 

(ground-volumes  'nil)) 

(loop  for  V  in  (universe-volumes  ‘universe*) 

do  (cond  ((equal  'ground  (volume-composition  (eval  V)  )  ) 

(setf  ground-volumes  (adjoin  V  ground-volumes) ) ) ) ; 

(setf  ground-volumes  (append  (universe-observers  "universe") 
groun  1-volumes) ) 

(setf  objects  (list  'nil 

(adjoin  path-name  ground-volumes) 

(adjoin  path-name  ground-volumes) 

(adjoin  path-name  ground-volumes) 

(adjoin  path-name  ground-volumes))) 

(loop  for  N  in  ' (1  2  3  4) 

do  (take-picture-4  (nth  N  *list-of-cameras*) 

(nth  N  "window-stats") 

(nth  N  objects) 

(nth  N  "display-stats") ) ) ) 

'  nil ) 

(defun  display-paths  (list-of-paths) 

;ex.  (display-paths  '(|path0002|  IpathOoll)) 
(setf  ‘window-stats*  '('nil 

(10  20  600  380  "Paths-over-ground"  15  140) 

(10  420  600  290  "Alternate-view  ”  20  140) 

(618  200  200  200  "Top-view"  7  60) 

(618  420  200  200  "Low-side  view"  7  60))) 

(setf  "display-stats*  (list  'nil 
•ideal* 

*high-left-f ront * 

•top* 

"right-side") ) 

(let  ((objects  'nil) 

(ground-volumes  'nil)) 

(loop  for  V  in  (universe-volumes  "universe*) 

do  (cond  ((equal  'ground  (volume-composition  (eval  V))) 

(setf  ground-volumes  (adjoin  V  ground-volumes))))) 

(setf  ground-volumes  (append  (universe-observers  "universe") 
ground-volumes) ) 

(setf  objects  (list  'nil 

(append  list-of-paths  ground-volumes) 

(append  list-of-paths  ground-volumes) 

(append  list-of-paths  ground-volumes) 

(append  list-of-paths  ground-volumes) ) ) 

(loop  for  N  in  ' (1  2  3  4) 

do  (take-picture-4  (nth  N  "list-of-cameras * ) 

(nth  N  "window-stats* ) 

(nth  N  objects) 

(nth  N  "display-stats")))) 

'  nil ) 
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SIMPLE  CAMERA  ORDERS  FOR  A  PICTURE  (MANUAL  CONTROL) 


(defun  take-picture-3 

(List-of-ob jeota  x  y  z  az  roll  rot  ox  oy  or  oaz  oroll  orot) 

(let  ((Camera  '*nikon*)) 

(aend  (eval  Camera)  initialize) 

(aend  (eval  Camera)  move  x  y  z  az  roll  rot  ) 

(loop  for  V  in  List-of-ob jecta 
do  (aend  (eval  V)  initialize) 
do  (send 

(eval  V) 

:translate-and-euler-angle-tranaform  ox  oy  oz  oaz  oroll  orot) 
do  (aend  (eval  Camera)  stake-picture  V)))) 

; - ADVANCED  CAMERA  ORDERS  FOR  A  PICTURE  (SEMI-AUTOMATIC  CONTROL) - 

(defun  take-picture-4  (Camera  Window-stats  List-of-ob jecta  view-stats) 
(cond  ((or  (null  view-stats) 

(null  list-of-ob jecta) ) 

(return-from  take-picture-4  'nil))) 

(aetf  *window-width*  (third  window-atats) ) 

(setf  *window-height*  (fourth  window-atats ) ) 

(aetf  *scale*  (sixth  window-stata) ) 

(setf  image-distance*  (seventh  window-atats)) 

(send  (eval  Camera)  : initialize-B  Window-stata) 

(send  (eval  Camera)  move  (first  view-stats)  ?  x 

(second  view-stats)  ;  \ 

(third  view-stats)  ;  z 

(fourth  view-stats)  ;  azimuth 

(fifth  view-stats)  ;  roll 

(sixth  view-stats) )  ;  rotation 

(loop  for  V  in  List-of-ob jects 
do  (aend  (eval  V)  initialize) 
do  (send 

(eval  V) 

: translate-and-euler-angle-tranaform 
(nth  6  view-stats) 

(nth  7  view-stats) 

(nth  8  view-stats) 

(nth  9  view-stats) 

(nth  10  view-stats) 

(nth  11  view-stats) ) 

do  (send  (eval  Camera)  stake-picture  V) 

do  (let  ((object-type  (string-trim  '"10123456789  ”  V))) 

(cond  ( (string-equal  object-type  ' "observer") 

(let*  (  (obs-point 

(first  (send 

(eval  V)  : get-transf ormed-node-list) ) ) 
(screen-point  (send 

(eval  Camera) 

: screen-transform  obs-point))) 

(send  (eval  (camera-*camerwindow*  (eval  Camera) ) ) 

: set-cursorpos  (-  (first  screen-point)  '30) 

(-  (second  screen-point)  '5)) 

(send  (eval  (camera-*camerwindow*  (eval  Camera) ) ) 
sdisplay-lozenged-atring  ' "obs") ) ) 

((string-equal  object-type  '"path") 
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Let*  ((start-point 

(first  (send  (eval  V) 

:get-transformed-node-list) ) ) 

(end-point 
(first  (last 
(send 
(eval  V) 

:get-tranaformed-node-liat) ) ) ) 

( screen -start -point 
(send  (eval  Camera) 

: screen-transform  start-point) ) 

( screen -end-point 
(send  (eval  Camera) 

: screen-transform  end-point))) 

(cond  ( (<  '50000  (*  ‘window-width*  ‘window-height*)) 
(send 

(eval  (camera-*camerwindow*  (eval  Camera) ) ) 

: set-cursorpos 

(-  (first  screen-start -point)  '43) 

(-  (second  screen-start -point)  '5)) 

(send 

(eval  (camera-*camerwindow*  (eval  Camera))) 
:display-lozenged-string  ' "start") 

(send 

(eval  (camera-*camerwindow*  (eval  Camera) ) ) 

: set-cursorpos 

(+  (first  screen-end-point)  '3) 

(-  (second  screen-end-point)  '5)) 

(send  (eval  ( camera-* camerwindow* 

(eval  Camera) ) ) 


: display-lozenged-string  ' "end") )))))))) 
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;  -*-  Mode: Common-Lisp;  Base: 10  -*- 

COMMON  FUNCTIONS 


This  file  consists  of  all  common  functions  used  by  most  of  the 
1  files  of  the  3-D  path  planning  software.  Function  vary  from  the 
very  general  (convenience)  functions,  to  very  detailed,  special 
purpose  functions  (which  happen  to  be  called  from  two  separate 
files) .  Functions  are  grouped  by  categories  of  Single  functions, 

Point  functions,  Vector  functions,  Line  functions.  Plane  functions. 

Facet  functions,  Volume  functions,  property  list  functions, 

detailed  (special  purpose)  functions,  and  finally,  printing  functions. 

D.H. Lewis/Thesis  07  AUG  88 

Modified 

L.R.Wrenn  08  Apr  89 

*************************************************************************** 

DIRECTORY  OF  FUNCTIONS 


SIMPLE: 

MEMBER-P 

EQUAL-P 

EQUAL-ZERO-P 

DISTANCE 

MERGE-JOIN-LIST 

POINTS: 

AVERAGE -OF-POINTS 

FIND-POINT 

AVERAGE-POINT 

FIRST-NON-ZERO 

EQUAL-ERROR 

LT,  GT,  GE,  LE 

VECTORS : 

SOLVE-FOR-T 

VECTOR-ADD-WITH-T 

LINES: 

MAKE-LINE 

LINE-CROSS-PRODUCT 

FIND-COMMON-POINT 

ANGLE-BETWEEN-LINES 

FIND-MID-POINT 

PLANES: 

MAKE-A-PLANE 

MAKE-A-NORMALIZED-PLANE 

MAKE- VERTICAL-PLANE 
MAKE-Z-PLANE 

MAKE-X-PLANE 

MAKE-Y-PLANE 

FACETS : 

FIND-COMMON-FACET 

MEAN-POINT-IN-A-FACET 

UP  U  .  T'l/"\  TVtrn 

SUBS -POINT- INTO -EQUATION 
SUBS-LINE-INTO-PLANE-EQUATION 

MEAN-POINT- IN-A-FACET-2 

INFO-ON-FACETS 

INSIDE-FACET-P 

VOLUMES :  INTERSECT-ALL-PLANES-WITH-VOLUMES 

I NTERSECT -ALL -P LANE S - WI TH - VOLUME S - 2 

PROPERTY  LISTS:  RESET-POINT-PROPERTY-LISTS 

DETAILED  FUNCTIONS:  MINIMUM-DISTANCE 
LOCATE-POINT-AIR 
LOCATE -POINT 
POINT- IN -VOLUME-P 
POINT-CHECK-P 
LINES-STRATTLE-FACETS-P 
SPEED-DEMON 
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;  PRINTING  FUNCTIONS:  DUMP-VOLUMES 
;  DUMP -PATH 

;  PRINT-POINTS 

;  PRINT-VECTORS 

;  PRINT-LINES 

;  PRINT-FACETS 

;  PRINT-VOLUMES 

.*★*****★******************************************************************* 

(defvar  ‘precision*  '0.0025) 

(defvar  *precision-2*  '0.25) 

- - SIMPLE  FUNCTIONS - 


(defun  member-p  (item  list)  ;  T  or  nil  member 

(not  (null  (member  item  list)))) 

(defun  equal -p  (listl  list2)  ;  are  two  lists  equal? 

(cond  ((equal  (length  listl)  (length  list2)) 

(apply  'and  (mapcar  'equal  listl  list2))))) 

(defun  equal-zero-p  (A)  ;  is  A  equal  to  zero? 

(cond  ((equal  (*  '1.0  A)  '0.0) 

(return-from  equal-zero-p  ’ t) ) ) 

'nil) 

(defun  t2  (pi  p2) 

(distance-z  pi  p2) ) 

;used  to  convert  Z-coord  from  10' s  of  feet  to  NM 

(setq  ‘conversion-matrix*  ’((100)  (010)  (00  0.0016458195  ))) 


(defun  distance  (PI  P2)  ;  distance  between  two 

points 

(let*  ((PI  (car  (matrix-multiply  (list  (send  (eval  PI)  : list-format ) ) 

♦conversion-matrix*) ) ) 

(P2  (car  (matrix-multiply  (list  (send  (eval  F2)  : list-format ) ) 

♦conversion-matrix*) ) ) 

(difference  (mapcar  '-  PI  P2))) 

(sqrt  (apply  '+  (mapcar  '*  difference  difference))))) 

(defun  distance-Z  (PI  P2)  ;  vertical  distance  between  two  points 

(let*  ((PI  (car  (matrix-multiply  (list  (send  (eval  PI)  : list-format ) ) 

•conversion-matrix*) ) ) 

(P2  (car  (matrix-multiply  (list  (send  (eval  P2)  : list-format ) ) 

•conversion-matrix*) ) ) ) 

(-  (third  p2)  (third  PI) )) ) 

(defun  climb-angle  (PI  P2) 

(let  ( (dist-total  (distance  PI  P2) ) 

(dist-Z  (distance-Z  PI  P2) ) ) 

('  (/  180  PI)  (asin  (/  dist-z  dist-total))))) 
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(defun  merge- join-list  (Listl  List2)  ;  join  the  two  lists  to  make 

(let  ( (lengthl  (length  listl))  ;  one  long  list 

(length2  (length  list2) ) 

(templist  'nil)) 

(oond  ( (>•  lengthl  length2) 

(setf  templist  listl) 

(loop  for  I  in  list2 

do  (setf  templist  (adjoin  I  templist)))) 

(t  (setf  templist  list2) 

(loop  for  I  in  listl 

do  (setf  templist  (adjoin  I  templist))))) 
templist) ) 


(defun  first-non-zero  (List)  ;  find  the  first  non-zero  element  in  a  simple 

list 


;  if  none  found,  return  "-1". 
(cond  ((not  (equal-zero-p  (first  List))) 

(first  List)) 

((not  (equal-zero-p  (second  List))) 

(second  List) ) 

( (not  (equal-zero-p  (third  List) ) ) 

(third  List)) 

(t  (-  1)))) 


(defun  equal-error  (A  B) 
error 

(let  ((error  'nil)) 

(cond  ( (equal  A  B) 

(return-from  equal-error  't)) 

( (equal  (*  '1.0  A) 

(*  '1.0  B) ) 

(return-from  equal-error  ' t ) ) 

( (or  (equal-zero-p  B) 
(equal-zero-p  A) ) 

(setf  error  '1.0)) 

((>  A  B) 

(setf  error  (abs  (/  (-  A  B)  B) ) ) 
(t  (setf  error  (abs  (/  (-  A  B)  A) 
(<=  error  ‘precision*) ) ) 


;  equal  within  an  allowed  level  of 

;  simple  equal 
;  floating  point  equal 

;  divide  by  zero  check 

;  find  absolute  error  between  terms 

))) 

;  check  with  allowed  precision 


(defun  equal-error-2  (A  B) 
error 

(let  ((error  'nil)) 

(cond  ( (equal  A  B) 

(return-from  equal-error-2  't)) 

( (equal  ( *  '1.0  A) 

(*  '1.0  B) ) 

(return-from  equal-error-2  't)) 
((or  (equal-zero-p  B) 
(equal-zero-p  A) ) 

(setf  error  '1.0)) 

((>  A  B) 

(setf  error  (abs  (/  (-  A  B)  B) ) ) 
(t  (setf  error  (abs  (/  (-  A  B)  A) 
(<«  error  *precision-2*) ) ) 

(defun  LT  (A  B) 

(and  (not  (equal-error  A  B) ) 

(<  A  B)  )  ) 

(defun  GT  (A  B) 


;  equal  within  an  allowed  level  of 


;  simple  equal 
;  floating  point  equal 


;  divide  by  zero  check 


;  find  absolute  error  between  terms 

) 

)  )  ) 

;  check  with  allowed  precision 
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(and  (not  (equal-error  A  B) ) 
(>  A  B)  )  ) 
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(defun  LE  (A  B) 
(not  (GT  A  B) ) ) 

(defun  GE  (A  B) 
(not  (LT  A  B)  )  ) 


; - MANIPULATE  POINTS - 

(defun  average-of-points  (list-of-pointa) 

(map  'list  '(lambda  (a  b)  (/  a  b) )  (mean-point -in-facet-2  liat-of-pointa) 

(make-list  3  : initial-element 
(length  liat-of-pointa) ) ) ) 

(defun  find-point  (X  Y  Z  Liat-of-pointa)  ;  find  all  pointa  in  liat  which  match 
(let  ( (result  List-of-pointa)  ;  one  or  more  of  specified  values, 

values 

(values  (liat  X  Y  Z) ) )  ;  of  'nil  will  be  ignored,  returns  a  list, 

(loop  for  Pass  in  (List  012) 

do  (cond  ((not  (equal  'nil  (nth  Pass  values))) 

(let  ((intermediate-result  'nil)) 

(loop  for  P  in  result 

do  (cond  ( (equal-error  (nth  Pass  values) 

(nth  Pass  (send  (eval  P)  : list-format )) ) 

(setf  intermediate-result 

(adjoin  P  intermediate-result) ) ) ) ) 

(setf  result  intermediate-result) ) ) ) ) 

result ) ) 


(defun  average-points  (Ptl  Pt2)  ;  find  the  point  1/2  way  between  two  points 
(map  'list  '/  (map  'list  '+  (send  (eval  Ptl)  : list-format) 

(send  (eval  Pt2)  : list-format) ) 

(make-liat  3  : initial-element  '2))) 


- - MAKE  OR  MANIPULATE  VECTORS - 

(defun  solve-for-t  (Plane  Line  Denom) 

(/  (-  (fourth  Plane)  (apply  '+  (map  'list  '*  Plane 

(send  (eval (Line-segment-position-vector 

(eval  Line)))  : list-format) )) )  Denom)) 

(defun  vector-add-with-t  (DV  PV  Ti)  ;  add  a  direction  vector  (*T)  to  a 
position  vector 

(map  'list  '+  (send  (eval  PV)  : list-format ) 

(map  'list  ♦' (lambda  (A)  (*  A  Ti))  (send  (eval  DV) 

•.list- format)  )  )  ) 


■MAKE  OR  MANIPULATE  LINES 


(defun  make-line  (Pointl  Point2) 

(init-line  (init-vector  '‘origin*  Pointl) 

(init-vector  Pointl  Point2) ) ) 

(defun  1 ine-cross-product  (LI  L2)  ;  take  the  cross  product  of  direction  vectors 

(cross-product  (send  (eval  (line-segment-direction-vector  (eval  LI))) 

:  list-format ) 

(send  (eval  (line-segment-direction-vector  (eval  L2))) 

:  list-format ) ) ) 
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(defun  find-common-point  (LI  L 2)  ;  returns  tha  valua  of  a  common 

point, 

(loop  for  m  in  (send  (aval  LI)  : endpoints)  ;  if  one  exists, 
do  (loop  for  n  in  (sand  (aval  L2)  :endpoints) 
when  (equal  m  n) 

do  (return-from  find-common-point  m) ) ) 

'nil) 

(defun  angle-between-lines  (LI  L2)  ;  find  the  smallest  angle  between  two 

lines 

;  return  HIL  for  unusual  problems 
(let*  ((normal-vector  (line-cross-product  LI  L2) ) 

(normal-vector-length  (sqrt  (abs  (+  (*  (first  normal-vector) 

(first  normal-vector) ) 

(»  (second  normal -vector) 

(second  normal-vector) ) 

(*  (third  normal-vector) 

(third  normal-vector) )))))) 

(cond  ( (equal-zero-p  normal-vector-length) 

(return-from  angle-between-lines  'nil)) 

((or  (equal-zero-p  (send  (aval  LI)  : length)) 

(equal-zero-p  (send  (aval  L2)  :length))) 

(return-from  angle-between-lines  'nil))) 

(-  *PI*  (asin  (/  normal-vector-length  (*  (send  (aval  LI)  : length) 

(send  (eval  L2)  : length) ))))) ) 


(defun  find-mid-point  (Line) 
(send  (eval  Line)  smidpoint) ) 


; - MAKE  OR  MANIPULATE  PLANES - 

(defun  make-a-plane  (point  line)  ;  define  a  plane  given  a  point  and  a  line 
(let*  ( (Obs-line  (init-line  (init-vector  '‘origin*  point) 

(init-vector  point 

(first  (send  (eval  line)  : endpoints) ))) ) 
(plane  (make-a-normslized-plane  Obs-line  line))) 

(init-plane  plane) ) ) 


(defun  make-a-normalized-plane  (LI  L2)  ;  make  a  plane  equation  with 

;  Ao  m  -1,0,1;  first  coef  is 

positive 

(let  ( (un-normalized  (line-cross-product  LI  L 2))  ;  normal  vector  to  plane 

(common-point  (find-common-point  LI  L2)) 

;  a  point  in  the  plane 

(Ao  'nil)  ;  constant  in  plane  equation 

(normalized  'ni1')  ;  in  standard  form 

(setf  un-norir  .zed  (map  'list  'rationalize  un-normalized)) 

(cond  ( (null  common-point) 

(setf  common-point  (send  (eval  (send  (eval  LI)  : start -point ) ) 

: list-format) ) ) 

(t  (setf  common-point  (send  (eval  comon -point)  :list-format) )  )  ) 

(setf  Ao  (apply  ' +  (mapcar  '*  common-point  un-normalized))) 

(cond  ( (equal-zero-p  Ao) 

(setf  normalized 

(map  'list  '/  un-normalized  (make-list  3  : initial-element 

(first-non-zero  un-normalized) ) ) ) 

(setf  normalized  (reverse  (append  (list  '0)  (reverse  normalized))))) 
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(t  (setf  normalized 

(map  'list  '/  un-normalized  (make-list  3  : initial-element  Ao)  ) ) 

(setf  normalized  (reverse  (append  (list  '1)  (reverse  normalized)))))) 
(cond  ( (GT  '0.0  (first -non-zero  normalized)) 

(map  'list  '*  (make-list  4  : initial -element  (-  1))  normalized)) 

(t  't)| 

(setf  normalized  (map  'list  'rationalize  normalized)) 
normalized) )  ;  return  the  coeffs  for  the  plane 


(defun  make-vertical-plane  (Line) 

(let*  ((line-endpoints  (send  (eval  Line)  :endpoints)) 

(Ptl  (map  'list  '+  '(0  0  10) 

(send  (eval  (first  line-endpoints))  : list-format) ) ) 
(LI  (make-line  (init-point  Ptl)  (second  line-endpoints) ) ) 

(L2  (make-line  (init-point  Ptl)  (first  line-endpoints)))) 
(init-plane  (make-a-normalized-plane  LI  L2)))) 


(defun  make-z-plane  (point) 

(init-plane  (make-a-normalized-plane 

(make-line  (init-point 

(map  'list  '+  (send  (eval  point  ) 
'  (10  0  0) )  ) 


point) 

(make-line  (init-point 

(map  'list  '+  (send  (eval  point) 

' (0  10  0))) 

point) ) ) ) 

(defun  make-y-plane  (point) 

(init-plane  (make-a-normalized-plane 

(make-line  (init-point 

(map  'list  '+  (send  (eval  point  ) 
'  <0  0  10))) 

point) 

(make-line  (init-point 

(map  'list  '+  (send  (eval  point) 

'  (0  10  0)  )) 

point) ) ) ) 


: list-format) 


list-format) 


: list-format) 


list-format) 


(defun  make-x-plane  (point) 

(init-plane  (make-a-normalized-plane 

(make-line  (init-point 

(map  'list  '+  (send  (eval  point  ) 
'  (10  0  0) )  ) 


point ) 

(make-line  (init-point 

(map  'list  '+  (send  (eval  point) 
'  (0  0  10)  )  ) 


point) ) ) ) 


: list-format) 


list-format) 


(defun  subs-point-into-equation 
(apply  '+  (map  'list  '*  (send 


(Plane  Point) 
(eval  Point) 


list-format)  Plane) ) ) 
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(defun  subs-line-into-plane-equation  (Line  Plane)  ;  TRUE  if  lines  lie  in 

plane 

(let*  ((endpoints  (send  (aval  Line)  tendpoints)) 

(point-Aos  (list  (send  (eval  plane) 

:subs-point-into-plane  (first  endpoints) ) 

(send  (eval  plane) 

:subs-point-into-plane  (second  endpoints))))) 

(apply  ' and 

(map  'list  #' equal-error 
point-Aos 

(make-list  2  : initial-element 

(fourth  (send  (eval  plane)  :list-coeff )))))) ) 

; - MANIPULATE  FACETS - 

(defun  f ind-con*non- facet  (VI  V2)  ;  find  the  first  facet  that  two  volumes  have 

in 

;  common.  Use  the  assumption  that  common 

facets 

;  will  have  same  name  first,  else  they  will 

have 

;  the  same  plane  equation. 

(let  ((common-facet  (first  (intersection  (volume-facets  (eval  VI)) 

(volume-facets  (eval  V2)))))) 

(cond  ((not  (null  common-facet)) 

(return-from  find-common-facet  common-facet)) 

((not  (null  (facet-connects  (eval  (first  (volume-facets  (eval  VI))))))) 
(loop  for  FI  in  (volume-facets  (eval  VI)) 

do  (cond  ( (member-p  V2  (second  (facet-connects  (eval  FI)))) 

(return-from  find-common-facet  FI))))) 

(t  (loop  for  FI  in  (volume-facets  (eval  VI)) 

do  (loop  for  F2  in  (volume-facets  (eval  V2) ) 
do  (cond  ((send  (eval  FI)  :test-equal  F2) 

(return-from  find-common-facet  F2) ))))))) 

'nil) 


(defun  mean-point-in-facet  (Facet) 

(map  'list  ' (lambda  (a  b)  (/  a  b) )  (mean-point-in-facet-2  (send  (eval  Facet) 
ipoints) ) 

(make-list  3  : initial-element 
(length  (send  (eval  Facet)  :points))))) 


(defun  mean-point-in-facet-2  (Points) 

(cond  ((null  Points)  '  (0  0  0)) 

(t  (map  'list  '+  (send  (eval  (first  Points))  : list-format) 
(mean-point-in-facet-2  (rest  Points)))))) 

(defun  info-on-facets  (list-of-f acets)  ;  find  all  points  and  lines  in  a  list 
of  facets 

(let  ( (lines  ' nil) 

(points  'nil)) 

(loop  for  F  in  list-of-f acets 
do  (let  () 

(setf  lines  (append  (facet-edges  (eval  F) )  lines) ) 

(setf  points  (append  (send  (eval  F)  :points)  points)))) 

(setf  lines  (remove-duplicates  lines)) 

(setf  lines  (remove  'nil  lines)) 

(setf  points  (remove-duplicates  points)) 

(setf  points  (remove  ' nil  points) ) 

(list  points  lines))) 
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(defun  inaide-facet-p  (point  facet)  ;  return  T  iff  point  ia  inaide 

(let  ( (horizontal-plane  (make-z -plane  point) )  ;  a  convex  facet 
(vertical-y-plane  (make-y-plane  point) ) 

(vertical-x-plane  (make-x-plane  point) ) 

(vertical-Ao-x  'nil) 

(vertical-Ao-y  'nil) 

(left-pointa  'nil) 

(right -pointa  'nil) 

(edge-pointa  'nil)) 

;  intercept  all  edgea  with  horizontal  plane, 

;  plane  interception  pointa  in  left  or  right 
;  half,  baaed  upon  relationahip  with  vertical 

plane 

(aetf  vertioal-Ao-x  (fourth  (aend  (aval  vertical-x-plane)  :liat-coeff ) ) ) 
(aetf  vertical -Ao-y  (fourth  (aend  (eval  vertical-y-plane)  : liat-coef f ) ) ) 
(loop  for  L  in  (facet-edgea  (eval  Facet) ) 

do  (let  ((I  (find-intercept-point  horizontal-plane  L) ) 

( I-Ao-x  'nil) 

(1-Ao-y  'nil)) 

(cond  ((not  (equal  'nil  I)) 

(aetf  I-Ao-y  (aend  (eval  vertical-y-plane)  : auba-point-into-plane 

T)> 

(aetf  I-Ao-x  (aend  (eval  vertical-x-plane)  : auba-point-into-plane 

I)  ) 

(cond  ( (LT  vertical-Ao-x  I-Ao-x) 

(aetf  right-pointa  (adjoin  I  right-pointa) ) ) 

( (GT  vertical-Ao-x  I-Ao-x) 

(aetf  left-pointa  (adjoin  I  left-pointa) ) ) 

(t  ( aetf  edge-pointa  (adjoin  I  edge-pointa) ) ) ) 

(cond  ( (LT  vertical-Ao-y  I-Ao-y) 

(aetf  right-pointa  (adjoin  I  right-pointa))) 

( (GT  vertical-Ao-y  I-Ao-y) 

(aetf  left-pointa  (adjoin  I  left-pointa))) 

(t  (aetf  edge-pointa  (adjoin  I  edge-pointa)))))))) 

;  teat  for  incluaion  by  nr  of  intercept  pointa 

(cond  ((or  (not  (evenp  (length  left-pointa)))  ;  if  either  one  odd,  then 

point 

(not  (evenp  (length  right-pointa))))  ;  ia  in  facet 
(return-from  inaide-facet-p  't)) 

(t  (return-from  inaide-facet-p  'nil))))) 


■MAKE  OR  MANIPULATE  VOLUMES 


(defun  interaect-all-planea-with-volumea  (liat-of-planea  Liat-of -volumes ) 

;  interaectal  all  planes  given  with  all  volumes  given, 

;  including  resultant  volumes  from  earlier  intersections. 
;  requires  input  of  volumes  as:  ((volume)  (volume)  ...) 

;  resultant  volume  list  is  the  same  format. 

(let  (  (old-list-of-error-planes  'nil) 

(result -volumes 

(interaect-all-planes-with-volumes-2  List-of-planes  List-of-volumes) ) ) 

(loop  repeat  ' 1 
do  (let  () 

(terpri)  (terpri) 

(princ  "  Re-doing  error  intercepts:  ”) 

(prinl  *liat-of-error-planes*)  (terpri) 
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(setf  old-list-of-error-planes  *list-of-error-planea*) 
(setf  *list-of-error-planes*  'nil) 

(set£  reault-volumea  (interaect-all-planea-with-volumea-2 
old-liat-of-arror-planaa 
raault-volumaa) ) ) ) 

reault-volumea) ) 


(dafun  intersect-all-planes-with-volumes-2  (Liat-of-planaa  Liat-of-volumaa) 

;  do  all  the  work  for  interaect-all-planea-with-volumes 
(let  ( (templiat  '())) 

(cond  ((null  liat-of-planaa)  liat-of-volumaa) 

(t  (loop  for  V  in  Liat-of-volumaa 
do  (let  ((temp  'nil)) 

(aetf  temp  (interaact  (car  V) 

(aand  (aval  (car  liat-of-planaa)) 
iliat-ooeff) ) ) 

(cond  ((equal  '1  (length  tamp)) 

(puah  tamp  templiat) ) 

(t  (puah  (liat  (firat  tamp))  tanp>liat) 

(puah  (liat  (aecond  temp) )  templiat) ) ) ) ) 
(interaect-all-planea-with-volumea-2  (cdr  liat-of-planaa)  templiat) ) ) ) ) 


- - PROPERTY  LIST  MANIPULATIONS - 

(dafun  reaet -point -property-liats  (Volume) 

(loop  for  P  in  (voluma-pointa  (aval  Volume) ) 
do  (aetf  (get  P  'linea)  'nil) 
do  (aetf  (get  P  'planes)  'nil) 
do  (aetf  (get  P  'distance)  'nil))) 


; - manipulate  global  counters - 

(defun  speed-demon  () 

(terpri)  (terpri)  ;  delete  *liat-of-?????*  lists 

to 

(princ  "*******SPEED-DEMON-INVOKED*******")  ;  speed  processing,  best  if 

(terpri)  (terpri)  ;  used  with  static  universe 

methods 

(setf  *list-of-vectors*  'nil)  ;  if  contents  of  old  lists 

still  needed 

(setf  *list-of-lines*  'nil) 

(setf  *list-of-points*  'nil) 

(aetf  *list-of-planes*  'nil) 

(make -null -vector ) 

(make-origin) ) 


; - MORE  SPECIFIC  STUFF - 

(defun  minimum-distance  (linea  start -point) 

(let  ((best-line  (first  lines))) 

(cond  ( (<  '1  (length  lines)) 

(loop  for  L  in  (rest  lines) 

do  (cond  ((>  (get  (send  (eval  L)  :other-end  start-point) 

' distance) 

(get  (send  (eval  best-line)  :other-end  start-point) 
' distance) ) 

(aetf  best-line  L) ) ) ) ) ) 

beat-line) ) 
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FIND  THE  VOLUME (S)  CONTAINING  A  GIVEN  POINT 


(d«fun  locate-point  (point) 

;  return  the  one,  two,  or  more  volumes  which  contain  the  point. 
;  multiple  volumes  are  possible  if  point  is  on  facet  or  vertex 
;  of  a  volume 

(let  ( (list-of-possible-volumes  (universe-volumes  ‘universe*)) 

(reject-volumes  'nil) 

(x-plane  (make-x-plane  point) ) 

(y-plane  (make-y-plane  point)) 

(z-plane  (make -z -plane  point))) 

;  loop  through  planes  which  define  point, 

;  removing  volumes  which  do  not  intersect  the  planes. 

;  point  is  located  in  volume (s)  which  are  left 

(loop  for  PI  in  (list  x-plane  y-plane  z-plane) 
do  (let  () 

;  loop  through  (modified)  list  of  candiate  volumes 

(loop  for  V  in  list-of-possible-volumes 

do  (let  ( (first-point -Ao  (send  (eval  PI)  : subs-point-into-plane 

(first  (volume-points  (eval  V) ) ) ) ) 

(Ao  (fourth  (send  (eval  PI)  : list-coef f ) ) ) ) 

;  see  if  volume  strattles  plane 

(cond  ( (not  (equal-error  first -point -Ao  Ao) ) 

(corid  (  (point-check-p  PI  f irst-point-Ao  Ao  V) 

(setf  reject-volumes  (adjoin  V  reject-volumes)))))))) 

;  remove  rejected  volumes  from  possible  location  of  points 

(loop  for  V  in  re ject -volumes 

do  (setf  list-of-possible-volumes  (remove  V  list-of-po3sible-volumes) ) ) 
(setf  reject-volumes  'nil))) 

;  select  actual  location  of  point  from  final  list 
;  of  volumes 

(loop  for  V  in  list-of-possible-volumes  ;  not  so  good 
do  (let  ((lines  'nil)) 

(loop  for  F  in  (volume-facets  (eval  V)) 

do  (setf  (get  F  'center)  (init-point  (mean-point-in-facet  F) ) ) 
do  (setf  lines  (adjoin  (make-line  Point  (get  F  'center))  lines))) 

(cond  (  (lines-strattle-facets-p  Lines  V) 

(setf  list-of-possible-volumes  (remove  V 
list-of-possible-volumes ) ) ) ) ) ) 

list-of-possible-volumes) ) 
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1  ■  111 

A  (defun  locate-point-air  (point) 

f  ;  raturn  tha  one,  two,  or  more  air  volume*  which  contain  the  point . 

;  multiple  volumes  are  possible  if  point  is  on  facet  or  vertex 
■  ►  ;  of  a  volume.  Same  as  locate-point  function,  except  that  ground 

;  volumes  are  removed 

(let  ( (list-of-possible-volumes  (universe-volumes  *univerae*)) 
l  (reject-volumes  'nil) 

(x-plane  (make-x-plane  point)) 

(y— plane  (make-y-plane  point)) 

(z-plane  (make -z-plane  point))) 

>  ;  loop  through  planes  which  define  point, 

;  removing  volumes  which  do  not  intersect  the  planes. 

;  point  is  located  in  volume (s)  which  are  left 

b 

(loop  for  PI  in  (list  x-plane  y-plane  z-plane) 
do  (let  () 

i 

I  ;  loop  through  (modified)  list  of  candiate  volumes 

i 

(loop  for  V  in  list-of-possible-volumes 

do  (let  ( (first-point-Ao  (send  (aval  PI)  : subs-point-into-plane 

(first  (volume-points  (eval  V))))) 

(Ao  (fourth  (send  (eval  PI)  :list-coef f ) ) ) ) 

;  see  if  volume  strattles  plane 

(cond  ( (not  (equal-error  first-point-Ao  Ao) ) 

(cond  ( (point-check-p  PI  first-point-Ao  Ao  V) 

(setf  re ject -volumes  (adjoin  V  re ject-volumes) )))))) ) 

S  remove  rejected  volumes  from  possible  location  of  points 

(loop  for  V  in  re ject-volumes 

do  (setf  list-of-possible-volumes  (remove  V  list-of-possible-volumes))) 
(setf  reject-volumes  'nil))) 

» 

;  select  actual  location  of  point  from  final  list 
;  of  volumes 

(loop  for  V  in  list-of-possible-volumes  ;  not  so  good 
do  (let  ((lines  'nil)) 

(loop  for  F  in  (volume- facets  (eval  V) ) 

do  (setf  (get  F  'center)  (init-point  (mean-point-in-facet  F) ) ) 
do  (setf  lines  (adjoin  (make-line  Point  (get  F  'center))  lines))) 

(cond  ( (linea-atrattle-faceta-p  Lines  V) 

(setf  list-of-possible-volumes  (remove  V 
list-of-possible-volumes) ) ) ) ) ) 


I 


;  remove  ground  volumes  from  list 

(loop  for  V  in  list-of-possible-volumes 

do  (cond  ((equal  'ground  (volume-composition  (eval  V))) 

(setf  list-of-possible-volumes  (remove  V  list-of-possible-volumes) ) ) ) ) 

list-of-possible-volumes) ) 


; 
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(defun  point -in- volume -p  (point  volume)  ;  return  T  iff  the  point  is  inside  the 
volume 

;  return  Nil  otherwise 
;  code  is  modified  version  of 

locate-point-air 

(let  ( (list-of-possible-volumes  (list  volume)) 

(reject-volumes  'nil) 

(x-plane  (make-x-plane  point)) 

(y-plane  (make-y-plane  point)) 

(z-plane  (make-z-plane  point))) 

;  see  if  point  is  a  vertex,  or  in  a  facet  of  the  volume 

(cond  ( (member-p  point  (volume-points  (eval  volume) ) ) 

(return-from  point-in-volume-p  't))> 

(loop  for  F  in  (volume-facets  (eval  volume)) 
do  (cond  ( (inside-facet-p  point  F) 

(return-from  point-in-volume-p  't)))> 

;  loop  through  planes  which  define  point, 

;  removing  volumes  which  do  not  intersect  the  planes . 

;  point  is  located  in  volume (s)  which  are  left 

(loop  for  PI  in  (list  x-plane  y-plane  z-plane) 
do  (let  () 


;  loop  through  (modified)  list  of  candiate  volumes 

(loop  for  V  in  list-of-possible-volumes 

do  (let  ( ( first -point -Ao  (send  (eval  PI)  :subs-point-into-plane 

(first  (volume -points  (eval  V) ) ) ) ) 

(Ao  (fourth  (send  (eval  PI)  : list-coef f ) ) ) ) 

;  see  if  volume  strattles  plane 

(cond  ((not  (equal-error  first-point -Ao  Ao) ) 

(cond  ( (point-check-p  PI  first-point-Ao  Ao  V) 

(setf  re ject -volumes  (adjoin  V  reject-volumes)))))))) 

;  remove  rejected  volumes  from  possible  location  of  points 

(loop  for  V  in  re ject -volumes 

do  (setf  list-of-possible-volumes  (remove  V  list-of-possible-volumes) ) ) 
(setf  reject-volumes  'nil))) 

(cond  ((null  list-of-possible-volumes)  ;  exit  condition 

(return-from  point-in-volume-p  'nil))) 

't)  ) 

(defun  point-check-p  (Plane  Basis-point-Ao  Ao  Volume) 

(loop  for  P  in  (rest  (volume-points  (eval  Volume))) 

do  (let  ( (next -point -Ao  (send  (eval  Plane)  : subs-point-into-plane  P))) 

(cond  ( (equal  next-point-Ao  Ao) 

(return-from  point-check-p  'nil)) 

( (or  (and  (GT  Ao  Next-point-Ao) 

(LT  Ao  basis-point-Ao) ) 

(and  (LT  Ao  Next-point-Ao) 

(GT  Ao  basis-point-Ao) ) ) 

(return-from  point-check-p  'nil))))) 
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(defun  linea-strattle-facets-p  (Linaa  Volume) 

(loop  for  L  in  Linas 

do  (loop  for  F  in  (volume -facets  (aval  Volume) ) 
do  (cond  ((sand  (aval  L)  : atrattle-plane-p  F) 

(return-from  lines-strattle-f acets-p  't))))> 

'nil) 


;  PRINT  GOOD-TO-KNOW  INFO  CONCERNING  THE  STATE 
;  OF  THE  "ONIVERSB*  INTO  A  DISK  FILE 


(dafun  dump -volume a  (liat-of-volumea) 

(aatq  "output-stream*  (open  "exp3 : lewis; run2"  .‘direction  soutput)) 

(print  "sending  data  to  file  (run2 )...”) 

(loop  for  V  in  Liat-of-volumas 
do  (let  () 

(terpri  "output-stream*)  (terpri  "output-stream")  (terpri  "output-stream") 
(print -volumes  (list  V)) 

(terpri  "output-stream") 

(print -points  (volume-points  (aval  V) ) ) 

(terpri  "output-stream") 

(print-lines  (volume-edges  (aval  V))) 

(terpri  "output-stream") 

(print-facets  (volume-facets  (aval  V) ) ) ) ) 

(terpri  "output-stream")  (terpri  "output -stream")  (terpri  "output-stream") 
(close  "output-stream") 

(print  "Done.")  'nil) 


(defun  dump-path  (path-name) 

(setq  "output-stream*  (open  "exp3 : lewis; path-dump"  : direction  : output ) ) 
(print  "sending  path  data  to  file  (path-dump) . . . ") 

(terpri  "output-stream")  (terpri  "output-stream")  (terpri  "output-stream") 
(print-path  path-name) 

(terpri  "output-stream") 

(print -points  (path-points  (eval  path-name) ) ) 

(terpri  "output-stream") 

(print-lines  (path-lines  (eval  path-name) ) ) 

(terpri  "output-stream") 

(print-facets  (path-facets  (eval  path-name))) 

(terpri  "output-stream")  (terpri  "output-stream")  (terpri  "output-stream") 
(close  *  output -stream* ) 

(print  "Done.") 

'nil) 
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* 


«**********““““““ 


;  PRINT  FLAVOR  FUNCTIONS 
******************************** 


20  May  1988 

********************************************** 


(defun  print-points  (List) 

(cond  ((null  List)) 

(t  (tarpri  ‘output -stream*) 

(prinl  "names  "  ‘output -stream*) 

(prinl  (oar  List)  ‘output-stream*) 
(send  (aval  (oar  List))  sprint) 
(print-points  (cdr  List))))) 


(defun  print-vectors  (List) 

(cond  ( (null  List) ) 

(t  (tarpri  ‘output-stream*) 

(prinl  "name:  "  ‘output-stream*) 

(prinl  (car  List)  ‘output-stream*) 
(send  (eval  (oar  List) )  sprint) 
(print-vectors  (cdr  List))))) 


(defun  print-lines  (List) 

(cond  ((null  List)) 

(t  (terpri  ‘output-stream*) 

(prinl  "names"  ‘output-stream*) 

(prinl  (car  List)  ‘output -stream*) 
(send  (eval  (car  List))  sprint) 
(print-lines  (cdr  List) ) ) ) ) 

(defun  print-facets  (List) 

(cond  ( (null  List) ) 

(t  (terpri  ‘output -stream*) 

(prinl  "names"  ‘output-stream*) 

(prinl  (car  List)  ‘output -stream*) 
(send  (eval  (car  List))  sprint) 
(print-facets  (cdr  List) ))) ) 


(defun  print -volumes  (List) 

(cond  ((null  List)) 

(t  (terpri  ‘output-stream*) 

(prinl  "names"  ‘output-stream*) 

(prinl  (car  List)  ‘output-stream*) 
(send  (eval  (car  List))  sprint) 
(print-volumes  (cdr  List) ) ) ) ) 
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(defun  print-path  (nan*) 

(terpri  ‘output- at ream*) 

(princ  "name:  "  *output-#tream*)  (prinl  name  ‘output -at ream*) 

(princ  "atart-pointi  "  ‘output-atream*) 

(prinl  (pa th-atart -point  (eval  name) )  ‘output-atream*) 

(terpri  ‘output-atream*) 

(princ  "end-point:  "‘output-atream*) 

(prinl  (path-end-point  (eval  name))  ‘output-atream*) 

(terpri  ‘output-atream*) 

(princ  "volumea:  "‘output-atream*) 

(prinl  (path-volumea  (eval  name))  ‘output-atream*) 

(terpri  ‘output-atream*) 

(princ  "faceta:  "‘output-atream*) 

(prinl  (path-faceta  (eval  name) )  ‘output-atream*) 

(terpri  ‘output-atream*) 

(princ  "linea:  "‘output-atream*) 

(prinl  (path-linea  (eval  name) )  ‘output-atream*) 

(terpri  ‘output-atream*) 

(princ  "pointa:  "‘output-atream*) 

(prinl  (path-pointa  (eval  name))  ‘output-atream*) 

(terpri  ‘output-atream*) 

(princ  "length:  "*output-atream‘) 

(prinl  (path-length  (eval  name))  ‘output-atream*) 

(terpri  ‘output-atream*) 

(princ  "total  K  valuea:  "‘output-atream*) 

(prinl  (path-total -K  (eval  name) )  *output-atream‘) 

(terpri  *output-atream‘) 

(princ  "maximum  detection  probability:  "‘output-atream*) 

(prinl  (path-max-detection-probability  (eval  name))  ‘output-atream*) 
(terpri  ‘output-atream*) 

(princ  "average  detection  probability:  "‘output-atream*) 

(prinl  (path-ave-detection-probability  (eval  name) )  ‘output-atream*) 
(terpri  *output-atream*) ) 
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;;  Mode:  LISP;  Syntax:  Common-lisp;  Package:  USER 

******************************************************************************* 

;;  MOVIE-CAMERA  FLAVORS  AND  METHODS  /Written  by  Dr  Sehung  Kwak 

;;  ;Mod  for  speed  by  Mark  Kindi 

;;  THESIS  L.R.  NRENN  12  Mar  1989 

/  7 

;;  Additions  and  Mods  for  Thesis  and  CS-4313 

******************************************************************************* 
Improved-Movie -Camera 

FLAVORS  AND  METHODS 


FLAVOR: 
METHODS : 


•Movie-camera 


initialize  ; set-up  for  movie-camera 

:initialize-B  ; set-up  for  movie-camera  used  by  advanced  functions 

:move  /sets  H-matrix  for  movie-camera 

:show  /displays  an  object  using  movie-camera 

NOTE:  clear-scene  removed  to  show  multi-objects 

:clear-scene  /refreshes  (clears)  the  non-visible 

window  of  movie-camera 

:make-visible  /does  bitblt  of  back-window  to  front-window 

:draw-line  /draws  line  to  back-window 

:kill  /removes  both  windows 

: screen-transform  /transforms  real-world 

list-of-points  to  screen-coords 

/display-label  /allows  for  labeling  of  objects  on  the  screen 


* 


DIRECTORY  OF  FUNCTIONS 


make -movie -cameras 
reset -window-stats 
movie-ground 
movie-ground-path 

show-path-4  /does  not  reset  windows  only  adds  path  and  ground 

show-movie-4 

******************************************************************************* 

(defflavor  movie-camera 

(H-matrix  image-distance  previous-point  scale 

‘movie-display-window*  ‘movie-window*  ‘movie-window-array*) 

0 

: initable-instance-variables) 
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(defmethod  (movie-camera  : Initialise) 

() 

(setf  H-matrix  '(<1000)  (0100)  (0010)  (0001))) 

(aetf  image-distance  * image-distance*  ) 

(setf  scale  "scale") 

(setf  "movie -display-window* 

(tvsmake-window  'tv:window 
:blinker-p  nil 

:position  *movie-window-position* 

: inside-width  * movie -window- ins ide-width* 

: inside-height  *movie-window-inside-height* 
:name  "movie-display-window” 

: save-bits  t 
:expose-p  t) ) 

(setf  *movie-window* 

(tv:make-window  'tv:window 
sblinker-p  nil 

:position  "movie-window-position* 

: inside-width  *movie-window-inside-width* 

: inside-height  *movie-window-inside-height* 
:name  "movie-window" 

: save-bits  t 
:expose-p  nil) ) 

(setf  "movie-window-array* 

(send  ‘movie-window*  :bit-array) ) ) 


(defmethod  (movie-camera  :initialize-B)  ; for  advanced  functions 
( window-stats ) 

(setf  H-matrix  '((1000)  (0100)  (0010)  (0001))  ) 

(setf  image-distance  "image-distance") 

(setf  scale  "scale*) 

(setf  "movie-display-window* 

(tv:make-window  ’tvrwindow 
:blinker-p  nil 

:position  (list  (first  window-stats) 

(second  window-stats)) 

: inside-width  (third  window-stats) 

: inside-height  (fourth  window-stats) 

:name  (fifth  window-stats) 

: save-bits  t 
:expose-p  t) ) 

(setf  "movie-window* 

(tv: make-window  'tv:window 
:blinker-p  nil 

:position  (list  (first  window-stats) 

(second  window-stats)) 

: inside-width  (third  window-stats) 

: inside-height  (fourth  window-stats) 

:name  (fifth  window-stats) 

: save-bits  t 
:expose-p  nil) ) 

(aetf  "movie-window-array* 

(send  "movie-window*  :bit-array) ) ) 


(defmethod  (movie-camera  :move) 

(x  y  z  azimuth  elevation  roll) 

(setf  H-matrix  (matrix-inverse 

(homogeneous-transform  azimuth  elevation  roll  x  y  z)))) 
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(defmethod  (movie-camera  : show) 

(solid-object) 

(let*  ((node-polygon-list  (send  solid-object  : get-node-polygon-liat) ) 

(screen-vector  (send  self  : screen-transform  (first  node-polygon-list))) 
(polygon-list  (second  node-polygon-list) )  ) 

;  (send  self  :clear-scene)  not  needed  for  multi  objeat  picture 
(dolist  (polygon  polygon-list) 

(send  self  : draw-polygon  polygon  screen-vector)) 

(send  self  : make-visible) ) ) 


(defmethod  (movie-camera  : dear-scene) 

0 

(tv: sheet-force-access  (*movie-window*) 
(send  *movie-window*  : refresh))) 


(defmethod  (movie-camera  : draw-polygon) 

(polygon  screen-vector) 

(let  (  (first-point  (first  polygon) ) 

(rest-points  (cdr  polygon))) 

(setf  previous-point  (elt  screen-vector  first-point) ) 

(dolist  (point  rest-points) 

(send  self  :draw-line  (elt  screen-vector  point))) 

(if  (>  (length  polygon)  2) 

(send  self  :draw-line  (elt  screen-vector  first-point))  ))) 


(defmethod  (movie-camera  :make-visible) 

0 

(send  *movie-display-window*  :bitblt 
tv:alu-seta 

•movie-window-inside-width*  ‘ 

•movie-window- inside-height* 

•movie -window-array* 

2  2  0  0)) 


(defmethod  (movie-camera  : draw-line) 

(next -point) 

(let  (  (current -point  next-point) ) 

(tv: sheet -force -access  (*movie-window*) 

(send  *movie-window*  :draw-line 

(first  previous-point)  (second  previous-point) 
(first  current -point)  (second  current-point)  ) 
(setf  previous-point  current-point))  )) 


(defmethod  (movie-camera  :kill) 

() 

(send  *movie-diaplay-window*  :kill) 
(send  *movie-window*  :kill)) 
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(def method  (movie-camera  : screen-transform) 

(node-vector) 

(do*  ((point-list  node-vector  (cdr  point-list)) 

(camera-point  nil) 

(point  nil) 

(z  nil) 

(screen-vector  nil)  ) 

{ (null  point-list)  screen-vector) 

(setf  point  (car  point-list) ) 

(setf  camera-point  (post -multiply  H-matrix  point) ) 

(setf  z  (*  -1  (third  camera-point) ) ) 

(cond  ((equal  0.0  z)  (setf  z  0.00001)) 

<t>) 

(setf  screen-vector  (append  screen-vector  (list  (list 
(+  (round  (*  scale  (/  (*  image-distance 

(first  camera-point))  z))> 

(/  *movie-window-inside-width*  2)) 

(-  (/  *movie-window-inside-height*  2) 

(round  (*  scale  (/  (*  image-distance 

(second  camera-point))  z) ))))))))) 


(defmethod  (movie-camera  : display- label)  ;allows  for  the  addition 

;  of  labels  to  display 
(V) 

(let  ((object-type  (string-trim  '"10123456789  "  V))) 

(cond  ((string-equal  object-type  '"observer") 

(let*  ( (obs-point  (first  (send  (eval  V)  : get-transformed-node-list) ) ) 
(screen-point  (car (send  self 

: screen-transform  (list  obs-point))))) 

(tv : sheet -f or ce-access  (*movie-window* ) 

(send  *movie-window*  : set-cur sorpos 
(-  (first  screen-point)  ’30) 

(-  (second  screen-point)  '5)) 

(send  *movie-window*  :display-lozenged-atring  '"obs") 

)  )  ) 


((string-equal  object-type  '"path") 

(let*  ((start-point  (first  (send  (eval  V) 

sget-transformed-node-list) ) ) 
(end-point  (first  (last  (send  (eval  V) 

sget-transformed-node-list) )  ) ) 
(screen-start-point  (car (send  self  : screen-transform 

(list  start-point) ) > ) 

(screen-end-point  (car (send  self  : screen-transform 

(list  end-point  ) ) ) ) ) 

(tv : sheet -for ce-access  ( *movie-window* ) 

(cond  ( (<  '10000  (*  *movie-window-inside-width* 
*movie-window-inside-height*) ) 

(send  *movie-window*  : set-cursorpos 

(-  (first  screen-start -point)  '43) 

(-  (second  screen-start-point)  '5)) 

(send  *movie-window*  sdisplay-lozenged-string  '"start”) 
(send  *movie -window*  : set-cursorpos 
(+  (first  screen-end-point)  '3) 

(-  (second  screen-end-point)  ’5)) 

(send  *movie-window* 


:display-lozenged-string  ' "end") ))))))) 
(send  self  : make-vis ible ) ) 
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advanced  movie— camera  functions  L.  R.  WRENN 


* 

;  All  items  commented  out  here  ere  also  defined  in  camera 

.***************************************************************** 

f 

(defvar  *movie-window-inside-width*  300) 

(defvar  ‘movie -window- inside -height*  300) 

(defvar  *movie-window-position*  '(10  10)) 

; (defvar  *acale*  10) 

; (defvar  ‘image-distance*  20) 

; (defvar  ‘thickness*  '5)  /  line  thickness,  in  pixels 

; (defvar  *ideal*) 

; (defvar  *low-left-front*) 

; (defvar  *high-left-front*) 

; (defvar  * low-right-front*) 

; (defvar  *right-side*) 

/(defvar  *left-rear-3/4*) 

; (defvar  *top*) 

/(defvar  *display-stats* ) 

(defvar  *rca-l*) 

(defvar  *rca-2*) 

(defvar  *rca-3*) 

(defvar  *rca-4*) 

(defvar  *rca-5*) 

(defvar  *rca-6*) 

(defvar  *list-of-vcrs*) 

/ (defvar  *window-stats*) 


(defun  make-movie-cameras  () 

(setf  *rca-l*  (make-instance  'movie-camera)) 

(setf  *rca-2*  (make-instance  'movie-camera)) 

(setf  *rca-3*  (make-instance  'movie-camera)) 

(setf  *rca-4*  (make-instance  'movie-camera)) 

(setf  *rca-5*  (make-instance  'movie-camera)) 

(setf  *iist-of-vcrs*  ' (*rca-l*  *rca-2*  *rcs-3*  *rca-4*  *rca-5») ) 

/  (setf  ‘ideal*  '(7500.0  3500.0  6200.0  2.0  0.0  0.9800  -500.0  -500.0  200.0  0.0 

0.0  0.0) ) 

/  (setf  *low-left-f ront *  '(100.0  200.0  4000.0  0.0  0.50  1.0  1.0  1.0  -1.5  0.0  0.0 

0.0)) 

z  (setf  ‘high-left- front*  ' (3500.0  -11900.0  5700.0  0.26  0.10  1.17 
/  -500.0  -500.0  200.0  0.0  0.0  0.0)) 

/  (setf  * low-right-front*  '(100.0  100.0  4000.0  0.0  0.5  1.5  1.0  1.0  1.0  0.0  0.0 

0.0)  ) 


/  (setf  *right-side*  '(00.0  -4000.0  1500.0  0.0  0.0  01.40 
/  -500.0  -500.0  200.0  0.0  0.0  0.0)) 

/  (setf  *  left -rear-3/ 4*  '(-500.0  0.0  4000.0  0.0  0.0  1.0  1.0  1.0  1.0  0.0  0.0 

0.0)  ) 

;  (setf  *top*  '(0.0  0.0  4000.0  0.0  0.0  0.0  -500.0  -500.0  200.0  0.0  0.0  0.0)) 
'nil) 


(defun  reset-window-stats  (window-stats)  /used  to  move  from  one  window  to 
another 

(setf  *movie-window-inside-width*  (third  window-stats) ) 

(setf  *movie-window-inside-height*  (fourth  window-stats) ) 

(setf  ‘scale*  (sixth  window-stats)  ) 

(setf  ‘image-distance*  (seventh  window-stats) ) ) 
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- - DISPLAY  GROUND  IN  (4  WINDOWS) - 

(defun  movie-ground  ()  ; initializes  and  displays  the  ground  in  4  views  for 

paths 

(setf  ‘window-stats*  '('nil 

(10  10  400  38 0  "Path-over-ground"  15  140) 

(10  410  400  290  "Alternate-view  "  20  140) 

(420  10  300  380  "Top-view"  5  140) 

(420  410  300  290  "Top-view  No  Reset  of  Paths”  5  140))) 
(setf  "display-stats*  (list  'nil 
♦ideal* 

*high-left-f ront* 

*top* 

*top*)  ) 

(let  ((objects  'nil) 

(ground-volumes  'nil)) 

(loop  for  V  in  (universe-volumes  "universe*) 

do  (cond  ((equal  'ground  (volume-composition  (aval  V))) 

(setf  ground-volumes  (adjoin  V  ground-volumes) ) ) ) ) 

(setf  ground-volumes  (append  (universe-observers  ‘universe*) 
ground-volumes) ) 

(setf  objects  (list  'nil 

ground-volumes 
ground-volumes 
ground-volumes 
ground-volumes  ) ) 

(loop  for  N  in  '  (1  2  3  4  ) 

do  (show-movie-4  (nth  N  *list-of-vcrs* ) 

(nth  N  "window-stats* ) 

(nth  N  objects) 

(nth  N  *display-stats*) ) ) ) 


'nil) 


(defun  movie-ground-path  (path-name) 
(setf  *window-stats*  '('nil 


displays  the  ground  and 
path  just  like  camera 


(10  10  400  380  "Path-over-ground"  15  140) 
(10  410  400  290  "Alternate-view  "  20  140) 
(420  10  300  380  "Top-view"  5  140) 

(420  410  300  290  "Low-side  view"  5  140))) 
(setf  *display-stats*  (list  'nil 
•ideal* 


"high- left -front  * 
*top* 

♦right-side*) ) 


(let  ((objects  'nil) 

(ground-volumes  'nil)) 

(loop  for  V  in  (universe-volumes  ‘universe*) 

do  (cond  ((equal  'ground  (volume-composition  (aval  V))) 
(setf  ground-volumes  (adjoin  V  ground-volumes) ) ) ) ) 
(setf  ground-volumes  (append  (universe-observers  ‘universe*) 
ground-volumes) ) 

‘  ' . 'nil 

ground-volumes  (list  path-name) ) 
ground- volumes  (list  path-name) ) 
ground-volumes  (list  path-name) ) 
ground-volumes  (list  path-name) ) ) ) 


(setf  objects  (list 
(append 
(append 
(append 
(append 
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(loop  for  N  in  '  (1  2  3  4  ) 

do  (show-movie-4  (nth  N  *list-of-vcrs*) 
(nth  N  *window-stats* ) 

(nth  N  objects) 

(nth  N  *display-stats*) ) ) ) 

'nil) 


;  display-movia-path  uaad  by  search  routines  to  display  the 
;  the  search  as  it  is  on  going.  Helpful  when  altering 

parameters 

;  and  observing  their  effect.  Note:  It  is  a  center  of  volume  to 
;  center  of  volume  display. 

(defun  display-movie-path  (agenda  start-point  ground-volumes) 

(let  ( (current -best-path) 

(temp-best-path  'nil) 

(temp-path-volumes  'nil) 

(temp-goal-volume  'nil)) 

(princ  " - New  Agenda  Sent  to  Movie-camera - ") (terpri) 

(setf  current-best -path  (car  agenda)) 

(setf  temp-goal-volume  (car  (agenda-item-path 

(aval  current-best-path) ) ) ) 

(setf  temp-path-volumes  (reverse  (agenda-item-path 

(aval  current -best-path) ) ) ) 

(setf  temp-best-path  (init-new-path  start-point 

( volume -arithmetic-center 
(aval  temp-goal-volume) ) 
temp-path-volumes 
'  nil 
'  nil 
'  nil 
'nil 
■nil)) 

(make-center-to-center-path  terry -best -path) 

(calc-path-and-stats  temp-best -path) 

(send  (aval  temp-best-path)  :initialize) 

(loop  for  N  in  '  (1  2  3  4) 

do  (cond  ((not  (equal  N  4)) 

(send  (eval  (nth  N  *list-of-VCRs*) ) 

:  clear-scerie )  )  ) 

do  (show-path-4  (nth  N  *list-of-VCRs*) 

(nth  N  *window-stats*) 
terry -best -path 
(first  ground-volumes) 

(nth  N  *display-stats* ) ) 
do  (cond  ((not  (equal  N  4)) 

(send  (eval  (nth  N  *  1 ist -of-VCRs * ) ) 

:display-label  temp-best-path) ) ) ) ) ) 
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; - ADVANCED  MOVIE-CAMERA  ORDERS  FOR  A  PICTURE  (SEMI-AUTOMATIC 

CONTROL) - 

(defun  show-path-4  (VCR  Window-stats  path  ground  view-stata) 
(reset-window-stats  Window-stats) 

(send  (evai  path)  :translate-and-euler-angle-trans£orm  (nth  6  view-stats) 

(nth  7  view-stats) 

(nth  8  view-stats) 

(nth  9  view-stata) 

(nth  10  view-stats) 

(nth  11  view-stats)) 

(send  (eval  VCR)  :show  (aval  ground)) 

(send  (eval  VCR)  :show  (eval  path))} 
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;;  -*-  Mode: Lisp;  Syntax:  Common-lisp 

******************************************************************************* 
FUNCTIONS  TO  INTERCEPT  A  VOLUME  WITH  A  PLANE  D.H. LEWIS  27May88 


; These  functions  intercept  planes  with  volumes  and  lines  with  planes.  Multiple 
;  tests  are  performed  to  ensure  proper  construction  of  new  volumes.  Facets  are 
;  rebuilt  each  time. 

;  Main  functions:  INTERSECT  (VOLUME  PLANE) 

;  FIND-INTERCEPT-POINT  (PLANE  LINE) 

;  Other  functions:  GET-INTERCEPT-POINT  (PLANE  LINE  T-INTERCEPT) 

;  PUT-LINE-IN-CORRECT-HALF  (LINE  PLANE) 

;  PUSH-ENDPOINTS  (LINE  VOLUME) 

;  MAKE-NEW-DIVIDING-LINES  (VOLUME  OLDPOINTS  NEW-POINTS) 

;  NEW-VALID-LINE  (P0INT1  P0INT2  VOLUME) 

;  IN-FACET-P  (P0INT1  POINT2  FACET) 

;  OUTSIDE-VOLUME  (LINE  VOLUME) 

;  DENOM- IN- INTERCEPT  (PLANE  LINE) 

;  GET-INTERCEPT-POINT-2  (LINE  T-INTERCEPT) 

.*******************************************************************★*********** 

(defvar  *lines-in-intercept-plane*  'nil) 

(defvar  *large-integer*  'le4) 

(defvar  *list-of-error-planes*  'nil)  ;  used  to  correct  errors  in 

interceptions 

(defun  intersect  (Volume  Plane) 

(let  ((old-precision  ‘precision*) 

(bad-euler-f lag  't) 

(new— volume 1  'nil) 

(new-volume2  'nil) 

(facet -planes  'nil) 

(intercept-plane  'nil)) 

(terpri)  (princ  "intersecting:  ")  (prinl  (list  Volume  Plane)) 

(princ  "  -  Result:  ") 

(setf  *lines-in-intercept-plane*  'nil) 

(cond  ( (bad-intersect-preconditions-p  Volume  Plane);  check  for  degenerate 
conditions 

(return-from  intersect  (list  volume)))) 

(setf  intercept-plane  (init-plane  Plane) ) 

(loop  for  F  in  (volume-facets  (aval  Volume) )  ;  get  all  planes  used 

do  (setf  facet-planes  (adjoin  (init-plane  (send  (eval  F)  : list-coef f ) ) 
facet-planes) ) ) 

(setf  facet-planes  (adjoin  intercept -plane  facet -planes) ) 

(setf  facet-planes  (remove-duplicates  facet-planes)) 

(loop  until  (or  (not  bad-euler-f lag)  (>  ‘precision*  (*  '5  old-precision))) 
do  (let  () 

;  clear  standard  volumes  before  use  (or  reuse) 

;  and  set  common  values 


(send  ‘above*  :clear) 

(setf  (volume-visibility  ‘above*)  (volume-visibility  (eval  Volume))) 
(setf  (volume-composition  ‘above*)  (volume-composition  (eval 

Volume) ) ) 

(send  *below*  rclear) 

(setf  (volume-visibility  *below*)  (volume-visibility  (eval  Volume))) 
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Volume) ) ) 


(setf  (volume-composition  ‘below* )  (volume-composition  (eval 


;  conduct  intercept 

(let  ((List-of-new-points  'nil) 

(list-of-old-points  'nil)) 

(loop  for  P  in  (volume-points  (eval  Volume)) 
do  (setf  (get  P  'lines)  'nil)) 

/intersect  each  line  of  volume 
(loop  for  Line  in  (Volume -Bdgea  (eval  Volume) ) 

do  (let  ( (new-point  (find-intercept -point  intercept -plane 

Line))) 

(cond  ((equal  new-point  'nil) 

(cond  ( (not  (subs-line-into-plane-equation  Line 

intercept-plane) ) 

(put-line- in-correct-half 
Line 

(first  (send  (eval  Line)  .'endpoints)) 
intercept-plane) ) ) ) 

( (member-p  new-point  (Volume-points  (eval  Volume))) 

(pushnew  new-point  list-of-old-points) 

(put-line-in-correct-half  Line  new-point  intercept-plane) ) 
(t  (pushnew  new-point  List-of-new-points) 

(place-intercept-point  Plane  Line  New-point) ) ) ) ) 

(make-new-dividing-lines  Volume  List-of-new-points 
list-of-old-points) ) 

(cond  < (not  (simple-volume-test-p) )  ;  check  degenerate  cases 

(setf  *preciaion*  old-precision) 

(return-from  intersect  (list  volume)))) 

;  build  new  facets  in  best  way  possible 

(cond  ((not  *not-convex-volumes* )  ;  do  convex  facets 

(make-facets  facet-planes  *above*)  ;  quick  facet  builder 
(make-facets  facet-planes  ‘below*) 

(cond  ((not  (check-eulers-relation-p) ) 

(setf  (volume-facets  ‘above*)  'nil) 

(setf  (volume-facets  *below*)  'nil) 

(make-all-facets  ‘above*)  ;  slow  facet  builder 

(make-all-facets  ‘below*)))) 

(t  (make-all-facets  ‘above*)  ;  do  non-convex  facets 

(make-all-facets  ‘below*) ) ) 

(cond  ((null  (intersection  (volume-facets  *above*) 

(volume-facets  *below*))) 

(force-facet  plane))) 

(cond  ((not  (check-eulers-relation-p)) 

(setf  ‘precision*  (*  ‘precision*  '2.0))) 

(t  (setf  bad-euler-f lag  'nil))))) 

(cond  ( (not  bad-euler-f lag) 

(setf  new-volumel  (make-volume-name) )  ;  give  legitimate  names  to  new 

(setf  new-volume2  (make-volume-name) )  ;  volumes 

(send  ‘above*  :make-equal  new-volumel) 

(send  ‘below*  :make-equal  new-volume2) 

(push  new-volumel  *liat-of-volumes* ) 

(push  new-volume2  *list-of-volumes*) 

(setf  ‘precision*  old-precision) 

(prinl  (intersection  (volume-facets  (eval  new-volumel) ) 
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(volume-facets  (aval  new-volume2) ) ) ) 

(return-from  intarsact  (list  new-volumel  new-volume2) ) >  ;  raturn 

naw  volumes 

(t  (satf  ‘precision*  old-precision) 

(satf  *list-of-error-planes* 

(adjoin  intaroapt -plana  *list-of-error-planes* ) ) 

(raturn-from  intersect  (list  Volume) )))> ) 

(dafun  subs-point-into-plane  (Pt  Plana) 

(sand  (aval  Plana)  : subs-point-into-plane  Pt) ) 

(defun  bad-intarsect-praconditions-p  (Volume  Plane)  ;  test  for  null  plane  (0  0 
0  0) 

;  and  facet  intercept  if 

convex 

(cond  ((equal  *zero-veetor*  (map  'list  '*  plana  *one-vector») ) 

(princ  "nil  (early  1)") 

(raturn-from  bad-intersect -preoonditions-p  't)> 

;  ( (not  *not-convax -volumes*) 

;  (loop  for  F  in  (volume-facets  (aval  Volume) ) 

;  do  (cond  ((send  (aval  F)  stest-equal  (init-plane  Plane)) 

;  (princ  "nil  (early  2)") 

;  (return-from  bad-intersect-preconditions-p  ' t) ) ) ) ) 

) 

'nil) 


(defun  find-intercept-point  (plane  line)  ;  find  intercept  point  of  plane  and 
line 

;  segment,  if  it  exists,  return  NIL 
;  if  not  exist 

(let  ( (denom  (rationalize  (denom-in-intercept  plane  line))) 

(t-intercept  'nil) 

(I-point  'nil)) 

(cond  ( (not  (equal-zaro-p  denom) ) 

(setf  t-intercept  (rationalize  (solve-for-t 

(send  (eval  plane)  :list-coeff) 

line 

denom) ) ) 

(setf  I-point  (get-intercept -point-2  line  t-intercept)))) 

I-point) ) 

(defun  denom-in-intercept  (plane  line)  ;  find  the  denominator  in  intercept 
equation 

(apply  '+  (map  'list  '*  (send  (eval  plane)  :list-coeff) 

(map  'list  'rationalize 

(send  (eval  (line-segment-direction-vector 

(eval  line)))  : list-format) ))) ) 


(defun  get-intercept -point-2  (line  t-intercept) 

;  return  the  name  of  a  valid  intercept 

point 

(let  ((I  'nil) 

(I-list  'nil)) 

(cond  ((not  (or  (GT  t-intercept  (line-segment-t-max  (eval  line))) 

(LT  t-intercept  '0.0))) 

(setf  I-list  (vector-add-with-t 

(line-aegment-direction-vector  (eval  line)) 
(line-segment-position-vector  (eval  line) ) 
t-intercept) ) 

(setf  I  (init-point  I-list)))) 

I)  ) 
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(defun  place-intercept -point  (Plane  Line  I)  ;  divide  old  line  at  I,  build  new 
linea 

(let  ((LI  'nil)  S  and  put  each  in  right  reaultant 

volume 


(L2  'nil)) 

(aetf  (get  I  'lines)  Line) 

(pushnew  I  (volume-points  ‘above*)) 

(pushnew  I  (volume-points  ‘below*)) 

(setf  LI  (make-line  I  (first  (send  (aval  Line)  ’.endpoints)))) 

(aetf  L2  (make-line  I  (second  (send  (eval  Line)  ten^ointa) ) ) ) 

(setf  (line-segment-characteristics  (eval  LI) )  ;  ridge  is  still  a 


ridge 


(line-segment-characteristics  (eval  Line) ) ) 

(setf  (line-segment-characteristics  (eval  L2) ) 

(line-segment-characteristics  (eval  Line) ) ) 

(cond  ( (LT  (fourth  Plane)  ;  which  volume  to  put  new  line  LI? 

(subs-point-into-equation  Plane 

(oar  (send  (eval  Line)  :endpoints 

)))) 

(pushnew  LI  (volume-edges  ‘above*) ) 

(push-endpoints  LI  '‘above*)) 

( (GT  (fourth  Plane) 

(subs-point-into-equation  Plane 

(car  (send  (eval  Line)  :endpoints 

)))) 

(pushnew  LI  (volume-edges  ‘below*) ) 

(push-endpoints  LI  ' *below‘) ) 

(t  )) 

(cond  ( (LT  (fourth  Plane)  ;  Which  volume  to  put  new  line  L2? 

(subs-point-into-equation  Plane 

(cadr  (send  (eval  Line)  : endpoints 

)))) 


(pushnew  L2  (volume-edges  *above*) ) 
(push-endpoints  L2  ' *above*| ) 

( (GT  (fourth  Plane) 


(subs-point-into-equation  Plane 

(cadr  (send  (eval  Line)  rendpoints 

>)>> 

(pushnew  L2  (volume-edges  ‘below* ) ) 

(push-endpoints  L2  '‘below*))))) 


(defun  put-line-in-correct -half  (Line  Point  Plane)  ;  put  a  preexisting  volume 
line 

;  into  the  correct  resultant 

volume 

(let  ( (Plane-Ao  (fourth  (send  (eval  Plane)  : list-coeff ) ) ) 

(other-point  (send  (eval  Line)  :other-end  Point))) 

(cond  ( (GT  (send  (eval  Plane)  : subs-point-into-plane  other-point) 

Plane-Ao) 

(pushnew  Line  (volume-edges  *above*) ) 

(push-endpoints  Line  '‘above*)) 

(t  (pushnew  Line  (volume-edges  ‘below*)) 

(push-endpoints  Line  '‘below*))))) 


(defun  push-endpoints  (Line  Volume) 

(pushnew  (first  (send  (eval  Line)  rendpoints))  (volume-points  (eval  Volume))) 
(pushnew  (second  (send  (eval  Line)  rendpoints) )  (volume-points  (eval 
Volume) ) ) ) 
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(defun  make-new-dividing-lines  (Volume  List-new-pointa  List-old-points) 

(loop  for  PI  in  List-new-points  ;  handle  case  where  no  pre-exitant  points 
involved 

do  (loop  for  P2  in  List-new-pointa 
do  (cond  ((not  (equal  PI  P2) ) 

(new-valid-line  PI  P2  Volume))))) 

(loop  for  PI  in  List-old-points  ;  add  pre-exitant  lines  and  points 
do  (loop  for  P2  in  List-old-points  ;to  new  volumes 
do  (cond  ((not  (equal  PI  P2)) 

(new-valid-line  PI  P2  Volume)  ;make  new  connecting  lines 

}then  find  old  ones 

(loop  for  Line  in  (volume-edges  (eval  Volume) ) 
do  (let  ((endpointl  (first  (send  (eval  Line)  :endpointa) ) ) 
(endpoint2  (second  (send  (eval  Line)  tendpoints) ) ) ) 
(cond  ((and  (or  (equal  PI  endpointl) 

(equal  PI  endpoint2)) 

(or  (equal  P2  endpointl) 

(equal  P2  endpoint2) ) ) 

(push-endpoints  Line  ‘above*) 

(push-endpoints  Line  ‘below*) 

(puahnew  Line  (volume-edges  ‘above*) ) 

(pushnew  Line  (volume-edges  *below*) ) 

(pushnew  Line  *lines-in-intercept-plane‘) ))))))) ) 

(loop  for  P-new  in  List-new-points  ;  add  new  lines  connecting  old  and  new 
do  (loop  for  P-old  in  List-old-points  ;  points  to  new  volumes 
do  (new-valid-line  P-new  P-old  Volume)))) 

(defun  new-valid-line 

(PI  P2  Volume)  ;  make  a  new  (and  valid)  line  between  PI  and  P2 

;  which  lies  inside  (or  along  an  edge)  of  Volume 
(loop  for  FI  in  (volume-facets  (eval  Volume) ) 
do  (cond  ((in-facet-p  PI  P2  FI) 

(let  ((Line  (make-line  PI  P2) ) ) 

(cond  ((not  (outside-volume  Line  Volume)) 

(push-endpoints  Line  ‘above*) 

(push-endpoints  Line  ‘below* ) 

(pushnew  Line  (volume-edges  *above*) ) 

(pushnew  Line  (volume-edges  *below*) ) 

(pushnew  Line  *lines-in-intercept-plane* ))))))) ) 

(defun  simple-volume-test-p  () 

(cond  ((or  (or  (>  '3  (length  (volume-points  *above*))) 

(>  '3  (length  (volume-points  *below*)))) 

(or  (>  '5  (length  (volume-edges  ‘above*))) 

(>  '5  (length  (volume-edges  *below*))))) 

(princ  "nil  (late  1)”) 

(return-from  simple-volume-test-p  'nil))) 

't) 

(defun  check-eulers-relation-p  () 

(cond  ((or  (not  (equal  '2  (+  (length  (volume-points  ‘above*)) 

(length  (volume-facets  *above*) ) 

(-  '0  (length  (volume-edges  *above*) ) ) ) ) ) 

(not  (equal  '2  (+  (length  (volume-points  *below*) ) 

(length  (volume-facets  *below*) ) 

(-  '0  (length  (volume-edges  ‘below*))))))) 

(princ  "  Violated  Eulers  relation  ")  (prinl  ‘precision*) 

(terpri)  /(dump-volumes  (list  '‘above*  '‘below*)) 

(princ  "  ") 

(return-from  check-eulers-relation-p  'nil))) 


107 


(defun  make-facets  (planes  volume) 

(loop  for  P  in  planes  ;  dear  plane  properties 

do  (setf  (get  P  'edges)  'nil)) 

(loop  for  P  in  planes  ;  find  which  lines  lie  in  which  planes 

do  (loop  for  E  in  (volume-edges  (eval  Volume)) 
do  (cond  ( (eube-line-into-plane-equation  E  P) 

(setf  (get  P  'edges)  (adjoin  E  (get  P  'edges))))))) 

(loop  for  P  in  planes  ;  build  legitimate  faoets 

do  (cond  ((and  (not  (null  (get  P  'edges))) 

(<-  '3  (length  (get  P  'edges)))) 

(setf  (volume-facets  (eval  Volume) ) 

(adjoin  (init-faoet-2  (list  (get  P  '  edges)  P) ) 

(volume-facets  (eval  Volume))))))) 

(loop  for  P  in  planes  ;  clear  plane  properties 

do  (setf  (get  P  'edges)  'nil))) 


(defun  force-facet  (Plane)  ;  force  a  facet  to  exist,  if  all  else  fails 
(let*  ( (lines-in-facet  *lines-in-intercept -plane*) 

(forced-facet  (init-facet-2  (list  lines-in-facet  (init-plane  Plane) ) ) ) ) 

(setf  (volume-facets  *above*)  (adjoin  forced-facet  (volume-facets  ‘above*) ) ) 
(setf  (volume-facets  ‘below*)  (adjoin  forced-facet  (volume-facets  *below*))) 
(princ  "  Forced  "))) 


(defun  in-facet-p  (PI  P2  F)  ;  return  T  iff  points  PI  and  P2  are  inside  facet  F 

(cond  ((and  (or  (member-p  (get  PI  'lines)  (facet-edges  (eval  F) ) ) 

(member-p  PI  (send  (eval  F)  ipoints))) 

(or  (member-p  (get  P2  'lines)  (facet-edges  (eval  F) ) ) 

(member-p  P2  (send  (eval  F)  ipoints)))) 

(return-from  in-facet-p  't)) 

(t  (return-from  in-facet-p  'nil)))) 


(defun  outside-volume  (Line  Volume)  ;  return  T  iff  line  is  outside  the  volume 

;  do  only  if  dealing  with  ground  volumes  or 
;  non-convex  air  volumes 

(cond  ( (or  *not-convex-volumes* 

(equal  'ground  (volume-composition  (eval  volume)))) 

(let  ((mid-point  (init-point  (send  (eval  line)  smidpoint) ) ) ) 

(cond  ( (point-in-volume-p  mid-point  volume) 

(return-from  outside-volume  ’nil)) 

(t  (return-from  outside-volume  't))))) 

(t  (return-from  outside-volume  'nil)))) 
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rotation  and  translation  coda  cs4452  1 7 may 8 8 


(defun  transpose  (A) 

(oond  ((null  (edr  A))  (mapcar  'list  (oar  A))) 

(t  (mapcar  ' cons  (oar  A)  (transpose  (cdr  A) ) ) ) ) ) 

(dafun  dot -product  (x  y)  ;A  vector  is  a  list  of  numerical  atoms. 

(apply  ' +  (mapcar  ' *  x  y) ) )  ;A  matrix  is  a  list  of  vectors  representing 

(defun  cross-product  (x  y) 

(list  (-  (*  (cadr  x)  (caddr  y) )  (*  (caddr  x)  (oadr  y) ) ) 

(-  (*  (caddr  x)  (car  y) )  (*  (car  x)  (caddr  y) ) ) 

(-  (*  (car  x)  (oadr  y) )  (*  (cadr  x)  (car  y> ) ) ) ) 

(defun  poat-multiply  (M  x)  ;the  rows  of  the  matrix. 

(cond  ( (null  (cdr  M) )  (list  (dot-product  (car  M)  x) ) ) 

(t  (cons  (dot-product  (car  M)  x)  (poat-multiply  (cdr  M)  x) ) ) ) ) 

(defun  pre-multiply  (x  M) 

(poat-multiply  (transpose  M)  x) ) 

(defun  matrix-mult iply  (A  B) 

(cond  ( (null  (cdr  A) >  (list  (pre-multiply  (car  A)  B) ) ) 

(t  (cons  (pre-multiply  (car  A)  B)  (matrix-multiply  (cdr  A)  B) ) ) ) ) 

(defun  cycle-left  (L)  (mapcar  'row-cycle-left  L) ) 

(defun  row-cycle-left  (R)  (append  (cdr  R)  (list  (car  R) ) ) ) 

(defun  cycle-up  (M)  (append  (edr  M)  (list  (car  M) ) ) ) 

(defun  unit-veccor  (one-column  length) 

(do  ( (n  length  (1-  n)) 

(R  nil  (cons  (cond  ( (»  one-column  n)  1)  (t  0))  R) ) ) 

( (zerop  n)  R) ) ) 

(defun  concat-matr ix  (A  B) 

(cond  ( (null  A)  B) 

(t  (cons  (append  (car  A)  (car  B) )  (concat -matrix  (cdr  A)  (cdr  B) ) ) ) ) ) 

(defun  augment  (A)  (concat-matrix  A  (unit-matrix  (length  A)))) 

(defun  normalize-row  (R)  (scalar-multiply  (/  1.0  (car  R) )  R) ) 

(defun  scalar-multiply  (a  x) 

(cond  ( (null  x)  nil) 

(t  (cons  (*  a  (car  x) )  (scalar-multiply  a  (cdr  x) ) ) ) ) ) 

(defun  solve-first -column  (M) 

(do*  ( (LI  M  (cdr  LI) ) 

(L2  (normalize-row  (car  M) ) ) 

(L3  (list  L2)  (cons  (vector-add  (car  LI) 

(scalar-multiply  (-  (caar  LI))  L2) )  L3) ) ) 

((null  (cdr  LI) )  (reverse  L3) ) ) ) 

(defun  vector-add  (x  y)  (mapcar  '+  x  y) ) 

(defun  first-n  (n  R) 

(cond  ((zerop  n)  nil) 

(t  (cons  (car  R)  (first-n  (1-  n)  (cdr  R) ) ) ) ) ) 

(defun  sguare-car  (M) 

(do  (  (m  (length  M)  ) 

(LI  M  (cdr  LI)) 

(L2  nil  (cons  (first-n  m  (car  LI))  L2))) 

((null  LI)  (reverse  L2)))) 

(setq  A  '  (  (1  1  1)  (2  1  2)  (3  2  3))) 

(setq  B  '  ((1  1  2)  (1  2  3)  (2  3  1))) 

(defun  ncdr  (n  L)  (cond  ((zerop  n)  L)  (t  (cdr  (ncdr  (1-  n)  L)  )  ) )  ) 

(defun  near  (n  L)  (cond  ((zerop  n)  nil) 

(t  (cons  (car  L)  (near  (1-  n)  (cdr  L) )  ) )  ) ) 

(defun  nmax-car-f irat  (n  L) 

(append  (max-car-first  (near  n  L) )  (ncdr  n  L) ) ) 
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(defun  matrix-inverse  (M) 

(do  ( (Ml  (max-car-first  (augment  M) ) 

(cond  ((null  Ml)  nil) 

(t  (nmax-car-f irat  n  (cyela-laft  (cycle-up  Ml)))))) 

(n  (1-  (langth  M) )  (1-  n)  > ) 

((or  (minuap  n)  (null  Ml))  (oond  ((null  Ml)  nil)  (t  (square-car  Ml)))) 
(aatq  Ml  (cond  ( (zerop  (caar  Ml) )  nil)  (t  (aolve-f irat-column  Ml) ) ) ) ) ) 
(defun  max-car-f irat  (L) 

(oond  ( (null  (adz  L)  )  L) 

(t  (if  (>  (aba  (caar  L) )  (aba  (oaar  (max-car-f irat  (cdr  t) ) ) ) )  L 
(appand  (max-car-firat  (cdr  L) )  (liet  (oar  L) )))))) 

(dafun  dh-matrix  (coarotata  ainrotata  coatwiat  aintwiat  langth  tranalata) 
(liat  (liat  coarotata  (-  (*  coatwiat  ainrotata)) 

(*  aintwiat  ainrotata)  < *  langth  coarotata)) 

(liat  ainrotata  (*  coatwiat  coarotata) 

(-  (*  aintwiat  coarotata))  (*  langth  ainrotata)) 

(liat  0.  aintwiat  coatwiat  tranalata)  (liat  0.  0.  0.  1.))) 


(dafun  homoganaoua-tranafonn  (azimuth  alavation  roll  x  y  z) 

(rotation-and-translation  (ain  azimuth)  (cos  azimuth)  (ain  alavation) 
(cos  alavation)  (ain  roll)  (cos  roll)  x  y  z) ) 


(dafun  rotation-and-tranalation  (spsi  cpal  ath  cth  aphi  cphi  x  y  z) 
(liat  (list  (*  cpsi  cth)  (-  (*  cpai  ath  aphi)  (*  apai  cphi)) 

(+  (*  cpai  ath  cphi)  (*  apai  aphi))  x) 

(liat  <*  apai  cth)  (+  <*  cpai  cphi)  (*  apai  ath  aphi)) 

(-  (*  apai  ath  cphi)  (*  cpai  aphi))  y) 

(list  (-  ath)  (*  cth  aphi)  (*  cth  cphi)  z) 

(liat  0.  0.  0.  1.) )) 


(dafun  A01  (dl) 

(dh-matrix  01010  dl) ) 

(dafun  A12  (d2) 

(dh-matrix  01010  d2) ) 

(dafun  A23  (d3) 

(dh-matrix  0  1  0  1  0  d3)  ) 

(dafmacro  A03  (dl  d2  d3) 

' (chain-multiply  ' ( (A01  ,dl)  (A12  ,d2)  (A23  ,d3)))) 

(dafun  A34  (thata4) 

(dh-matrix  (coa  theta4)  (ain  theta4)  0100)) 

(defun  A45  (thetaS) 

(dh-matrix  (coa  thetaS)  (ain  theta5)  0100)) 

(dafun  A56  (theta6) 

(dh-matrix  (coa  theta6)  (ain  theta6)  0100)) 

(dafmacro  A36  (theta4  theta5  theta6) 

' (chain-multiply  '((A34  ,theta4)  (A45  ,theta5)  (A56  ,theta6)))) 
(dafun  A0 6  (dl  d2  d3  theta4  theta5  thata6) 

(matrix-multiply  (A03  dl  d2  d3)  (A36  theta4  theta5  theta6) ) ) 

(aatq  A6body  '((0010)  (1000)  (0100)  (0001))) 

(dafun  homogeneous -tr ana forml  (azimuth  elevation  roll  x  y  z) 

(matrix-multiply  (A06  z  x  y  (+  azimuth  pi)  (-  elevation  (/  pi  2) ) 
(+  roll  pi))  A6body) ) 

(aatq  B6body  '((1000)  (00-10)  (0100)  (0001))) 

(dafun  homogeneoua-trana£orm2  (azimuth  alavation  roll  x  y  z) 
(matrix-multiply  (A06  z  x  y  azimuth  alavation  roll  )  B6body  )) 

;  changes:  D.H. Lewis  17  May  88 
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(defun  unit-matrix  <L) 

(loop  for  i  from  L  downto  1 
collect  (loop  for  j  from  L  downto  1 
when  (equal  i  j) 
collect  1 
else  collect  0 
finally) 
finally) ) 

<d*fond°Uequal1aengthLI,)  2)  (matrix-multiply  (aval  (first  L> )  (aval  (second 

L)>>(t  (setq  temp  (matrix-multiply  (aval  (first  L)>  (aval  (second  L) ) ) ) 
(chain-multiply  (push  'temp  (cddr  !>)))))) 


Ill 


;;  Mode : Common-Lisp;  Bass: 10 

****************************************************************************** 


PATH-DATA  L.R.  WRBNN  31  May  89 


Tha  data  for  a  path  is  printad  out  in  jat-card  form. 
****************************************************************************** 
;;  FUNCTION  LIST 

l  t 

;;  MAIN:  PATH-DATA  :prints  out  jatcard  typa  information  about  a  path 
•I  PATH-FOR-IRIS  : sands  tha  information  naadad  to  display  a  path 

;;  on  tha  IRIS  to  a  fila  of  "pathnama.dat" 


ft  SUPPORT  FUNCTIONS  : 

a  a 
r  t 

;;  distance-XY 

; ;  raal-to-intagar 

;;  convart-numbar-to-string 

; ;  convert-string-to-integar 

;  ;  f ind-period-index 

; ;  get-laftsida-of-raal 

; ;  get-rightside-of-real 

; ;  oonvert-atring-to-raal 

•  • 

.  .****************************************************************«************ 
»  » 

(defun  path-data  (path)  ; prints  a  jet-card  and  outputs  the 

;  total  cost  of  a  path 

(let*  ((point-list  (path-points  (eval  path))) 

(min-PD-cost  '1000000) 

(max-PD-cost  '0)) 

(terpri) 


(princ  " 

Leg") 

(terpri) 

Leg 

Total 

Leg 

Total 

Leg 

Fuel 

Vol 

PD 

(princ  "Point 

Time 

Time 

Dist 

Dist 

Fuel 

Remain 

PD 

Cost 

Cost") 

(terpri) 

(princ  (send  (eval  (car  point-list))  : list-format-real) ) (terpri) 
(princ  "  0.0  0.0  0.0  0.0  0.0  1500 

-”) 

(terpri) 

(do*  (  (start-point  (car  point-list)  (car  point-list) ) 

(point-list  (cdr  point-list) (cdr  point-list) ) 

(volume-list  (path-volumes  (eval  path))  (cdr  volume-list)) 
(next-point  (car  point-list)  (car  point-list) ) 

(leg-dist  (distance-XY  start-point  next-point) 

(distance-XY  start-point  next-point) ) 

(total-dist  leg-dist  (+  leg-dist  total-dist) ) 

(leg-time  (/  (distance  start-point  next-point)  (/  450  60) ) 

(/  (distance  start-point  next-point)  (/  450  60))) 
(total-time  leg-time  (+  leg-time  total-time) ) 
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(log-fuel  (fuel-burned  (distance  start-point 

next -point) 

(climb-angle  start-point 
next -point) 

'  1500 
'450) 

(fuel-burned  (distance  start-point 
next -point) 

(climb-angle  start-point 
next -point) 

Fuel-remaining 

'450)) 

(fuel-remaining  (-  1500  leg-fuel) (-  fuel-remaining  leg-fuel) ) 

(PD  (volume-probability-of-detection  (aval  (car  volume-list))) 
(volume-probability-of-deteetion  (aval  (oar  volume-list)))) 
(PD-cost  (*  100  PD  leg-time) (*  100  PD  leg-time)) 

(leg-cost  (+  leg-fuel  PD-cost)  (+  leg-fuel  PD-cost)) 

(total-cost  leg-cost  (+  leg-coat  total-coat) ) 

(min-PD-cost  (cond((<  PD-cost  min-PD-cost) 

PD-cost) 

(t  min-PD-cost)) 

(cond((<  PD-cost  min-PD-cost) 

PD-cost) 

(t  min-PD-cost))) 

(max-PD-coat  (cond((>  PD-cost  max-PD-cost) 

PD-cost) 

(t  max-PD-cost)) 

(cond((>  FD-cost  max-PD-cost) 

PD-cost) 

(t  max-PD-cost)))) 

((null  (second  point-list)) 

(princ  (send  (eval  next-point)  : list-format-real) ) (terpri) (princ  " 


(princ 

(format 

nil 

"~7, IF" 

leg-time) ) 

(princ 

(format 

nil 

"~7, IF" 

total-time) ) 

(princ 

(format 

nil 

” ~7 , IF” 

leg-dist) ) 

(princ 

( format 

nil 

"~1, IF" 

total-dist) ) 

(princ 

(format 

nil 

"~7, IF" 

leg-fuel) ) 

(princ 

(format 

nil 

"-7, IF" 

fuel -remaining) ) 

(princ 

(format 

nil 

"~6, 3F" 

PD)) 

(princ 

(format 

nil 

"-7, IF" 

PD-COBt) ) 

(princ 

(format 

n  il 

"~7, IF” 

leg-cost) ) (terpri) 

(princ 

"Total  cost 

of  this 

path  -  ”) 

(princ 

(format 

nil 

"~7, IF" 

total-cost)) (terpri) 

(princ 

"minimum  PD 

cost  - 

") 

(princ 

(format 

nil 

"~7, IF" 

min-PD-cost) )  (terpri) 

(princ 

"maximum  PD 

cost  - 

”) 

(princ 

(format 

nil 

"~7, IF" 

max-PD-cost) ) (terpri) 

(princ 

"average  PD 

coat  - 

”) 

(princ 

(format 

nil 

"~7, IF" 

(/  total-cost  total-time) )) (terpri) 

(terpri)  total-cost) 

(princ  (send  (eval  next-point)  : list-format-real) ) (terpri) (princ 
(princ  (format  nil  ”~7,1F”  leg-time)) 


(princ 

(format 

nil 

"~7, IF" 

total-time) ) 

(princ 

(format 

nil 

"~7, IF" 

leg-dist) ) 

(princ 

( format 

nil 

"-7, IF" 

total-dist) ) 

(princ 

(format 

nil 

"~7, IF" 

leg- fuel) ) 

(princ 

(format 

nil 

"-7, IF" 

fuel-remaining) ) 

(princ 

(format 

nil 

"~6, 3F" 

PD)  ) 

(princ 

(format 

nil 

”~7, IF" 

PD-cost) ) 

(princ 

(format 

nil 

"~7, IF" 

leg-cost) ) 

(terpri) ) ) ) 

") 
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(defun  distance-XY  (ptl  pt2)  ; finds  tha  ground  distance 

;  between  two  points 

(sqrt  (+  (*  (-  (point-X-ooord  (aval  ptl))  (point-X-coord  (aval  pt2))) 
(-  (point-X-ooord  (eval  ptl))  (point-X-coord  (eval  pt2)))) 

(*  (-  (point-y-coord  (eval  ptl))  (point -y-coord  (eval  pt2))) 

(-  (point-y-coord  (eval  ptl))  (point-y-coord  (eval  pt2))))))) 


(defun  path-for-XRIS  (path)  /makes  a  file  of  the  points  of  a  path  for 

;  use  on  IRIS  Graphic  Display 

(aetq  ‘output-stream*  (open  (string-append  "exp3 :wrennthesis; " 

(symbol -name  path) 

".dat")  /direction  /output)) 

(print  "sending  path  data  to  file  ('path-name' .dat)...") 

(let*  ( (point-list  (path-points  (eval  path) ) ) 

(start-point-list  (send  (eval  (oar  point-list))  /list-format-real)) 
(list-length  (length  point-list) ) 

(volume-list  (path-volumes  (eval  path) ) ) ) 

(terpri) 

(princ  list-length  ‘output -stream*) (terpri  ‘output-stream*) 

(princ  (format  nil  "~8,2F"  (first  start-point-list))  *output-stream*) 
(princ  (format  nil  "~8,2F"  (third  start -point-list) )  *output-stream*) 
(princ  (format  nil  "~8,2F"  (*  -1.0  (second  start-point-list))) 

•output-stream*) 

(princ  (format  nil  "~7,3F”  (volume-probability-of-detection 

(eval  (car  volume-list) ) ) )  ‘output-stream* ) 

(terpri  ‘output-stream* ) 

(do*  ((point-list  (cdr  point-list) (cdr  point-list)) 

(start-point-liat  (send  (eval  (car  point-list) )  : list-format-real) 
(send  (eval  (car  point-list))  : list-format-real) ) 

(volume-list  (path-volumes  (eval  path))  (cdr  volume -1 ist ) ) 

(PD  (volume-probability-of-detection  (eval  (car  volume-list))) 
(volume-probability-of-detection  (eval  (car  volume-list) ) ) ) ) 

( (null  (second  point-list) ) 

(princ  (format  nil  ”~8,2F"  (first  start -point-list) )  ‘output-stream* ) 
(princ  (format  nil  "~8,2F"  (third  start-point-list) )  ‘output-stream* ) 
(princ  (format  nil  "~8,2F" 

(*  -1.0  (second  start-point-list)))  ‘output-stream* ) 

(princ  (format  nil  "~7,3F" 

(volume-probability-of -detect ion 

(eval  (car  volume-list))))  ‘output-stream*) 

(terpri  ‘output-stream*)  PD) 

(princ  (format  nil  "~8,2F"  (first  start-point-list))  ‘output-stream* ) 
(princ  (format  nil  "~8,2F"  (third  start -point-list) )  ‘output-stream* ) 
(princ  (format  nil  "~8,2F" 

(*  -1.0  (second  start -point-list) ) )  *output-stream*) 

(princ  (format  nil  "~7,3F"  (volume-probability-of-detection 

(eval  (car  volume-list) ) ) )  ‘output-stream* ) 

(terpri  ‘output-stream*) ) 

) 

(close  ‘output-stream*) 

(print  "Done.”) 

'nil) 


(defun  real-to-integer  (realnum)  /returns  integer  part  of  real  number 
(get-leftside-of-real  (convert -number-to-string  realnum) ) ) 
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(defun  convert -number-to-string  (n) 

(princ-to-string  n) ) 

(defun  convert-string-to-integer  (str  Soptional  (radix  10) ) 

(do  (  ( j  0  (+  j  1)) 

(n  0  (+  < *  n  radix)  (digit-char-p  (char  str  j)  radix)))) 

(<-  j  (length  str))  n) ) ) 

(defun  find-period-index  (str) 

(catch  ' exit 

(dotimes  (x  (length  str)  nil) 

(if  (equal  (char  str  x)  (char  0)) 

(throw  '  exit  x) ) ) )  ) 

(defun  get-leftside-of-real  (str  Soptional  (radix  10) ) 

(do  ((j  0  (1+  j)) 

(n  0  (+  (*  n  radix)  (digit-char-p  (char  str  j)  radix)))) 

(  (or  (null  (digit-char-p  (char  str  j)  radix) )  («  j  (length  str) ) )  n) 

(defun  get-rightside-of-real  (str  Soptional  (radix  10) ) 

(do  ( (index  (1+  (find-period-index  str) )  (1+  index) ) 

(factor  0.10  (*  factor  0.10)) 

(n  0.0  (+  n  (*  factor  (digit-char-p  (char  str  index)  radix))))) 

( (=  index  (length  str) )  n  ) ) ) 

(defun  convert-string-to-real  (str  Soptional  (radix  10) ) 

(+  (float  (get-leftside-of-real  str  radix) )  (get-rightside-of-real  str 

radix) ) ) 
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;;  -*-  Mode :Common-Lisp;  BaseslO  -*- 

****************************************************************************** 
PATH-OPTIMIZATION  L.R.  WRENN  6  Mar  89 


The  optimization  code  optimizes  the  initial  A*  path  according 
to  snells  law  criteria. 

****************************************************************************** 
THESIS  L.R. WRENN  15  JUNE  1989 

MAIN  FUNCTIONS:  RANDOM-RAT -OPTIMIZE 
RANDOM-RAT-OPT2 
REVISE -PATH 

SUPPORT  FUNCTIONS: 

AD JUST-PATH- INTO -LAST -VOLUME 

AD JUST-PATH-INTO-LAST- VOLUME-2 

REFINE -LINE -TO -GOAL 

ADJUST-VECTOR 

REVISE-PATH-2 

CONNECT-POINTS 

GET-VECTOR-AND -FACTOR 

SWITCH-ADJUSTMENTS 

ADJUST-POINT 

NORMAL-LINE 

MAKE-A  PATH-PLANE 

ANGLE-BETWEEN-LINE-FACETN 

ANGLE-BETWEEN-LINES-SMALLEST 

F I ND -SNELLS -ANGLE 

FIND-OUTBOUND-VECTOR 

FIND -OUTBOUND- VECTOR-2 

F 1 ND -OUTBOUND- VE  CTOR -3 

SOLVE-QUADRATIC 

FIND-OUTBOUND-LINE -2 

FIND-POINT-FROM-COEF-AND-POINT 

MAKE -UNIT-LINE 

PARALLEL-LINES 

FINE-INTERCEPT-POINT-EXTENDED 
GET- INTERCEPT-POINT- 2 -EXTENDED 
NORMAL I Z E- VECTOR 
GET-ADGUSTMENT-VECTORS 
CHECK-FACET-LIST-AGAINST-SNELLS-LAW 

★  ♦♦♦★♦♦♦♦A**************************'****************************************** 

(defvar  *ref lectance*) 
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(defun  random- ray-optimize  (path-list)  ;Takes  a  list  of  paths  are  trys 

;  random  ray  optimization  on  them 
;  returns  a  list  of  paths  that  worked 
;  or  nil  corresponding  to  those  that 
;  did  not . 

;  ex.  (random-ray-optimization  '(Ipath0006| 

IpathOOll | ) ) 

(let  ( (new-paths  ) ) 

(do*  ( (old-path-list  path-list  (edr  old-path-list) ) 

(current -path  (car  old-path-list) (car  old-path-list)) 

(random-ray-worked  (random-ray-opt2  current-path) 

(random-ray-opt2  current-path) ) 

(new-path-list  (cond  ( (null  random-ray-worked) 

(list  nil) ) 

(t  (list  (revise-path  current-path 

random-ray-worked) ) ) ) 

(cond  ( (null  random-ray-worked) 

(cons  'nil  new-path-list)) 

(t  (cons  (revise-path  current-path 
random-ray-worked) 
new-path-list) ) ) ) ) 

((null  (cdr  old-path-liet) ) 

(setf  new-paths  (reverse  new-path-list) ) ) ) 

(terpri) 

(princ  "Old  Paths  -  New  Paths") (terpri) 

(do  ((old-path  (car  path-list) (car  path-list)) 

(new-path  (car  new-paths) (car  new-paths)) 

(path-list  (cdr  path-list) (cdr  path-list) ) 

(new-paths  (cdr  new-paths) (cdr  new-paths))) 

((null  path-list) (princ  old-path) (princ  "  -  ") 

(princ  new-path) (terpri)  new-paths) 

(princ  old-path) (princ  "  -  ") (princ  new-path) (terpri) ) 

new-paths) ) 
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(defun  random-ray-opt2  (path) 


Takes  a  path  and  cheaks  to  see  if  it  is 
possible  to  pass  a  random  ray  through 
the  volumes  obeying  Snell's  Law  at  all 
facets.  Hill  return  a  line  if  it  can 
or  ' nil  if  it  cannot . 
ex.  (random-ray-opt2  'Ipath0006|) 


(setf  ‘reflectance*  5) 

(let*  ( (line-to-goal  (make-line  (path-start-point  (eval  path)) 

(path-end-point  (eval  path) ) ) ) 

(facet-list  (path-facets  (eval  path) ) ) 

(volume-list  (path-volumes  (eval  path)))) 

(do*  ((IP 

(find-intercept-point-extended  (car  facet-list) 

line-to-goal) 

(find-intercept-point-extended  (car  facet-list) 

line-to-goal) ) ) 

( (point-in-volume-P  IP  (car  volume-list)) 

(setf  line-to-goal  (make-line 

(path-start-point  (eval  path) ) 

(find-intereept-point-extended  (oar  facet-list) 

line-to-goal) ) ) ) 

(setf  line-to-goal  (make-line  (path-start-point  (eval  path) ) 
(init-point 

(average -points 
IP 


(facet-center 

(eval  (oar  facet-list)))))))) 

(cond  ( (not  (null  (check-f acet-list-against-snells-law 
line-to-goal  facet-list  volume-list) ) ) 

(terpri) (princ  "A  random  solution  has  been  found  into  the  goal  volume") 
(terpri) (princ  "The  line  to  start  the  path  is  -  ") 

(princ  line-to-goal) (terpri) 

(refine-line-to-goal  line-to-goal  path) ) 

(t 

(setf  line-to-goal  (ad juat-path-into- last -volume 

line-to-goal  facet-list  volume-list) ) 

(cond  ((null  line-to-goal) 

(terpri) 

(princ  "There  is  no  solution  to  the  random  ray  optimization") 
(terpri) (princ  "Try  one  of  the  other  optimizations") (terpri) 
(return-from  random-ray-opt2  ’nil))) 

(terpri) 

(princ  "A  random  solution  has  been  found  into  the  goal  volume") 

(terpri) 

(princ  "  by  adjusting  the  line  to  goal.  The  line  to  start  the  path  is  - 

(princ  line-to-goal) (terpri) 

(princ  "the  line  in  the  last  volume  is  -  ") 

(princ  (check-f acet-list-against-snells-law 

line-to-goal  facet-list  volume-list) ) (terpri) 
(refine-line-to-goal  line-to-goal  path) ) 

))) 
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(defun  ad just-path-into-last -volume  ;This  function  is  called 

(line-to-goal  facet-liat  volume-list)  ;  recursively  to  find  an 

;  adjustable  line  to  the  final 
;  volume  of  a  path.  Returns 
;  the  line  or  'nil 

(let*  ((line-out-of-last-facet) 

(IP) 

( adjustment -vectors ) 

(miss-distance  999999.0)) 

(cond  ((not (null  (cdr  facet-list))) 

(setf  line-to-goal  (ad just-path-into-last -volume 
line-to-goal 
(but-last  facet-list) 

(but-last  volume-list))))) 

(terpri) (princ  "In  check-line-with-adjustments") (terpri) 

(princ  "facets  -  ") (princ  facet-list) (terpri) 

(princ  "volumes  -  ") (princ  volume-list) (terpri) 

(princ  "line-to-goal  -  ") (princ  line-to-goal) (terpri) 

(cond  ( (null  line-to-goal) 

(return-from  ad juat-path-into-last-volume  'nil))) 

(cond  ((null  (cdr  facet-list)) 

(setf  line-out-of-last-facet  line-to-goal)) 

(t (setf  line-out -of-laat-facet  (check-facet-list-against-snells-law 

line-to-goal 
(but-last  facet-list) 

(but-last  volume-list))))) 


(cond  ( (null  line-out-of-last-facet) 

(return-from  ad just-path-into-last-volume  'nil))) 

(setf  IP  (find-intercept -point -extended  (oar  (last  facet-list)) 

line-out-of-last-facet) ) 

(princ  "The  intercept  point  is  -  ") (princ  IP) (terpri) 

(cond  ((and  (point-in-volume-P  IP  (car  (last  volume-list))) 
(check-facet-list-against-snells-law 
line-to-goal 
facet-list 
volume-list) ) 

(return-from  ad just-path-into-last-volume  line-to-goal) ) 

(t  (setf  adjustment-vectors  (get-adjustment-vectors 

IP 

(car  (last  facet-list)))) 

(setf  miss-distance  (distance 
IP 

(facet-center 

(eval  (car  (last  facet-list)))))))) 

(princ  "The  ad justment -vectors  and  miss-distance  is  -  ") (terpri) 
(princ  adjustment-vectors) (terpri) (princ  miss-distance) (terpri) 

(setf  line-to-goal  (ad just-path-into-last-volume-2 
line-to-goal 
IP 

miss -distance 
facet-liat 
volume-list 
ad justment- vector a 
line-out-of-last-facet) ) 

line-to-goal) ) 
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(defun  adjust-path-into-laat-volurae-2  (lina-to-goal 

IP 

miaa-diatanca 
facat-liat 
volume- li at 
ad justment- vectors 
line-out-of-laat- facet) 

;this  la  tha  actual  aaction  that  doaa  tha  adjustments 
/This  do*  will  ba  axitad  with  a  valid  naw  lina-to-goal  and 

;  line -out -of- last-facet  or  will  axit  with  'nil  causing  no  path  to  ba  found 

(do*  ( (naw-lina-to-goal  lina-to-goal) 

(adjuatmant-faotor  ' 125) 

(adjust-temp) 

(IP-2  IP) 

(old-raf lection  'nil) 

(IP-90deg  'nil) 

(reflected  'nil) 

(new-misa-distance  miaa-diatanca) 

(adjuatment-list  ' ("in"  "down"  "out"  "up"  "change") 

(cond  (reflected 

(cond  ( (<■  old-raf lection  *ref lectance*) 

(aatf  adjuat-tamp 

(awitch-ad juatmanta 

adjuatment-list  adjustment-factor) ) 

(aatf  adjustment-factor  (cadr  adjust-temp) ) 

(car  adjust-temp) ) 

(t  (setf  old-reflection  "reflectance*) 
adjuatment-list) ) ) 

( (<  miss-distance  new-misa-distance) 

(aatf  adjust-temp 

(switch-adjustments 
adjuatment-list  adjustment-factor) ) 

(setf  adjustment-factor  (cadr  ad just -temp) ) 

(car  adjuat-tamp) ) 

(t 

(setf  misa-diatance  new-misa-distance) 
adjustment-list) ) ) ) 

/exit  condition 

( (and  (point-in-volume-P  IP  (car  (last  volume-list) ) ) 

(not  (null (check-facet-list-against-snells-law 
new-line-to-goal 
facet-list 
volume-list ) )  ) ) 

(setf  line-to-goal  new-line-to-goal) ) 


(terpri) 

(cond( (<  adjustment-factor  '1) 

(return-from  ad just-path-into-last-volume-2  'nil))) 
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(cond  ((and (null  (but-laat  facet-list) )  ;la  thara  only  ona  facet  and 

;is  IP  on  it 

(point- in-voluma-P  IP  (car  (last  volume-list) ) ) ) 

(princ  "adjustment  hit  facet  but  reflected  in  first  volume  ”) (terpri) 
(cond  (reflected 

(satf  reflected  't) 

(setf  adjustment-list  ' ("in"  "down"  "out"  "up"  "change") ) 

(satf  adjustment-factor  '125))) 

(cond ((null  old-reflection) 

(setf  old-reflection  "reflectance*))) 

(princ  "‘reflectance*  -  ") (princ  *ref leetanoe*) (terpri) 

(princ  "old-reflection  -  ") (princ  old-reflection) (terpri) 

(cond((<  "reflectance*  old-reflection) 

(setf  line-to-goal  new-line-to-goal) 

(setf  IP  IP-2)))) 


( (point-in-volume-P  IP  (car  (last  volume-list))) 

(terpri) 

(princ  "We  have  an  intersect  point  but  it  will  not  go  through") (terpri) 
(cond  (reflected 

(setf  reflected  't) 

(setf  adjustment-list  '("in"  "down"  "out"  "up"  "change")) 

(setf  adjustment-factor  '125))) 

(cond ((null  old-reflection) 

(setf  old-reflection  *ref lectance* ) ) ) 

(setf  IP-90deg 

(find-intercept -point-extended 
(car (last  facet-list)) 

(make-unit-line  (send  (eval  line-out-of-last-facet) 

: start -point) 

(normal-line  IP 

(car  (last  facet-list)))))) 

(setf  miss-distance  (distance  IP 

IP-90deg) ) 

)  ) 


(setf  new-line-to-goal  (make-line 

(vector-start -point 

(eval  ( line-aegment-direction-vector 
(eval  line-to-goal)))) 
(adjust-point 

(vector-end-point 

(eval  ( line -segment -dir action -vector 
(eval  line-to-goal)))) 

(car  (get-vector-and-factor 
ad justment -vectors 
adjustment-list 
adjustment-factor) ) 

(cadr  (get-vector-and-factor 
ad justment-vectors 
ad justment- list 
adjustment-factor) ) ) ) ) 
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(cond< (null  (but-last  facet-list)) 

(princ  "adjustment  missed  everything  out  of  first  faaet  adjustments  made 
(terpri) 

(setf  new-line-to-goal  (make-line  (send  (eval  line-to-goal) 

: start -point) 

(facet -aenter 

(eval  (car  (last  faaet-list) ) ) ) ) ) 

(setf  IP-2  (find-intercept -point -extended  (car  (last  facet-list)) 

new-line-to-goal) ) 

(setf  new-miss-distance  (distance 

IP-2 

(facet-center 

(eval(car  facet-list))))) 

(cond((and  (null  reflected) (<  new-miss-distance  miss-distance)) 

(setf  line-to-goal  new-line-to-goal) 

(setf  IP  IP-2)))) 


;we  missed  the  last  facet-see  if  we 
/missed  the  next  to  the  last 
( (null  (check-facet-list-against-snells-law 
new-line-to-goal 
(but-laat  facet-list) 

(but-last  volume-list))) 

(princ  "adjustment  missed  everything  ") (terpri) 

(setf  new-miss-distance  (+  1  miss-distance) ) ) 


(t  (setf  line-out-of-last-facet  (check-facet-list-against-snells-law 

new-line-to-goal 
(but-last  facet-list) 

(but-last  volume-list))) 

(princ  "adjustment  may  be  ok") (terpri) 

(setf  IP-2  (find-intercept -point -extended  (car  (last  facet-list)) 

line-out-of-last-facet) ) 

(setf  new-miss-distance  (distance 

IP-2 

(cond  (reflected  IP-90deg) 

(t  (facet-center 
(eval (car 

(last  facet-list) ))))))) 

(cond((and  (null  reflected)  (<  new-miss-distance  miss-distance)) 
(setf  line-to-goal  new-line-to-goal) 

(setf  IP  IP-2))))) 

) 

line-to-goal) 
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(defun  ref ine-line-to-goal  (line  path)  ;thia  function  will  edjuat  the 

;  line  aa  cloae  to  the  actual 
;  goal  aa  it  can  and  report  the  reaulta 
;  Returns  the  beat  line 
(terpri) (princ  "In  ref ine-line-to-goal  ") 

(terpri) (princ  "The  path  we  are  optimizing  ia  -  ") (princ  path) (terpri) 

(let*  ((facet-liet  (path-facets  (aval  path))) 

(volume-list  (path-volumea  (aval  path*)) 

(start-point  (path-start-point  (aval  path) ) ) 

(line-to-goal  line) 

(ad justment -vector) 

(adjustment-factor  '125) 

(angle  pi) 

(check-line  (check-facet-list-against-anella-law 
line-to-goal 
facet-list 
volume-list) ) ) 

(princ  "check-line  looks  like  -  ") (princ  check-line) (terpri) 

(do*  ( (line-out-of-last-facet  (check-facet-iist-against-anella-law 
line-to-goal 
facet- list 
volume-list) 

(check- facet- list- against- anells-law 
new- line-to-goal 
facet-list 
volume-list) ) 

(line-facet-to-goal  (make-line 

(send  (eval  line-out-of-last-facet)  sstart-point) 
(path-end-point  (eval  path) ) ) 

(make-line 

(send  (eval  line-out-of-last-facet)  sstart-point) 
(path-end-point  (eval  path) ) ) ) 

(dist-facet-to-goal  (send  (eval  line-facet-to-goal)  s length) 

(distance  (send 

(eval  line-out-of- last-facet) 
sstart-point) 

(path-end-point  (eval  path) ) ) ) 

(new-line-to-goal  line-to-goal) 

(new-angle  (angle-between-lines-smallest  line-facet-to-goal 

line-out-of-last-facet) 

(angle-between-lines-smallest  line-facet-to-goal 
line-out-of-last-facet) ) ) 

( (<  new-angle  '0.0025)  line-to-goal) 

(terpri) 

(princ  "point  in  last  volume  we  are  trying  to  adjust  -  ") 

(princ  (send 

(eval  (adjust-point 

(send  (eval  line-out-of-last-f acet)  sstart-point) 
(normalize-vector (send 
(eval 

( line-segment -direct ion-vector 
(eval  line-out-of-last-facet))) 
slist-format) ) 
dist-facet-to-goal) ) 
s list-format-real) ) (terpri) 
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(setf  ad justment -vector 
(liat  (normalize-vector 
(append 
(aend 

(aval  (line-eegment-direction-vector 
(aval 

(make- line 

(ad juat-point 
(aend 

(aval  line-out-of-laat-facet) 
s start -point) 

(normalize-vector (aend 
(aval 

(line-segment-direction-vector 
(aval  line-out-of-la*t-facet) ) ) 
:liat-format) ) 
dist-faoet-to-goal) 

(path-end-point  (aval  path) ) 

)))) 

: list-format) 

' (0))))) 

(princ  "the  ad justment -vector  is  -  ") (princ  ad justment -vector) (terpri) 
(print  "the  adjustment-factor  is  -  ") (print  adjustment-factor) (terpri) 
(setf  new-line-to-goal  (make-line 
start -point 

; (vector-start -point 
;  (aval  (line-segment-direction-vector 
;  (oval  new-line-to-goal) ) ) ) 

(adjust-point 
( vector -end -point 

(aval  ( line-segment -dir act ion-vector 
(aval  line-to-goal) ) ) ) 

(car  (get-vector-and-factor 
adjustment-vector 
' ("in") 

adjustment-factor) ) 

(cadr  (get-vector-and-factor 
adjustment-vector 
'  ("in") 

adjustment-factor) ) ) )  ) 

(princ  "check  of  new  line  -  ") 

(princ  (check- facet- list -against -snails- law 
new-line-to-goal 
facet-list 

volume-list)) (terpri) 

(cond  ((null  (check-facet-list-against-snells-law 
new-1 ine-to-goal 
facet-list 
volume-list) ) 

(princ  "new  line  did  not  meet  snails  law") (terpri) 

(setf  adjustment-factor  (/  adjustment-factor  5)) 

(setf  new-line-to-goal  line-to-goal)) 

(t  (cond  ( (<  new-angle  angle) 

(setf  angle  new-angle) 

(setf  line-to-goal  new-line-to-goal) ) 

(t  (setf  new-line-to-goal  line-to-goal) 

(setf  adjustment-factor  (/  ad justment -factor  5)))))) 

(cond  ( (<  adjustment-factor  '0.008) 

(princ  "Adjusted  as  close  as  possible  but  still  missed  goal”) (terpri) 
(princ  "Miss  angle  in  radians  is  -  ") (princ  angle) (terpri) 
(return-from  ref ine-line-to-goal  new-line-to-goal)))) 
line)) 
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(defun  revise-path  (path  line) 


/Takes  the  old  path  and  the  new  random  ray 
;  line  and  makes  a  new  path  out  of  than. 

;  Returns  new  path  name 

(let  ((line-list) 

(new-path) 

(path-list  (revise-path-2  line 

(path-facets  (aval  path) ) 

(path- volumes  (aval  path) ) 

(list  (path-start-point  (aval  path) ) ) ) ) ) 

(satf  path-list  (reverse  (cons  (path-end-point  (aval  path) ) 

path-list) ) ) 

(setf  line-list  (connect -points  path-list) ) 

(setf  new-path  (init-new-path  (path-atart-point  (aval  path) ) 
(path-end-point  (aval  path) ) 

(path-volumes  (aval  path) ) 

(path-facets  (aval  path) ) 

line-list 

path-list 

'  nil 

'nil)) 

(calc-path-and-stats  new-path) 
new-path) ) 


(defun  revise-path-2  /Called  recursively  to  revise  the  old 

;  path  to  a  goal  with  the  random  ray 
(line  facet-list  volume-list  point-list) 

(cond  ((not  (null  (cdr  facet-list))) 

(setf  point-list  (revise-path-2  line 

(but-last  facet-list) 

(but-last  volume-list) 
point-list) > ) ) 

(setf  point-list  (cons  (send  (eval  (check-facet-list-against-snells-law 

line 

facet-list 
volume-list) ) 

: start -point) 
point-list) ) 

point-list) 


(defun  connect -points  (pointa-list)  /Connects  a  list  of  points  and 

/  returns  the  list  of  lines 

(do*  ((current-point  (car  points-list) (car  new-points-list) ) 
(new-points-liat  (cdr  points-list) (cdr  new-points-list) ) 

(line-list  (list  (make-line  current-point  (car  new-points-list))) 
(cons  (make-line  current-point  (car  new-points-list) ) 
line-list) ) ) 

((null  (cdr  new-points-list) ) (reverse  line-list)))) 


(defun  but-last 
(reverse  (cdr 


(listL)  /returns  all  but  the  last  item  in  the  list 
(reverse  listL)))) 
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(defun  get-vactor-and-factor  (ad justmant-vactors 

curr-adj-list 
curr-adj ) 

(let  ((return-list)) 

(cond  ((aqua!  "in”  (oar  ourr-adj-liat) ) 

(satf  raturn-liat 

(list  (car  ad justmant-vactors) 
curr-adj) ) ) 

( (aqual  "up"  (car  curr-ad j-liat) ) 

(satf  raturn-liat 

(list  (cadr  ad justmant-vactors) 
curr-adj) ) ) 

( (aqual  "out"  (oar  ourr-adj-list) ) 

(satf  raturn-liat 

(list  (car  ad justmant-vactors) 

(*  ' -1  curr-adj)))) 

( (aqual  "down"  (oar  curr-adj-list) ) 

(satf  raturn-liat 

(list  (cadr  adjustment -vactors) 

(*  -1  curr-adj))))) 

raturn-list) ) 

(defun  switch-adjustments  (curr-adj-list  curr-adj) 

(satf  curr-adj-list  (append  (cdr  ourr-adj-list) (list  (car  curr-adj-list)))) 
(cond  ((equal  "change"  (car  curr-adj-list)) 

(satf  curr-adj  (/  curr-adj  5) ) 

(setf  curr-adj-list  (append  (cdr  curr-adj-list) 

(list  (car  curr-adj-list)))))) 

(list  curr-adj-list  curr-adj)) 

(defun  adjust-point  <*-  -(  ;  vector  factor) 

(init-point 

(map  'list  '+  (.--nd  (aval  point)  : list-format ) 

(acalar-multip-y 
factor 
vector) ) ) ) 


(defun  normal-line  (point  facet)  ,-makes  normal  of  facet  into  a  line  at  point 

(let"  ((end-point-normal-line 

(init-point  (map  'list  '+  (send  (aval  Point)  : list-format) 

(map  'list  '*  '(100  100  100) 

(send  (aval  facet)  : list-coef f-3) ) ) ) ) 

(N-line  (make-line  Point  end-point-normal-line) ) ) 

N-line) ) 

(defun  make-a-path-plane  (Line-1  Facet)  ;  makes  a  plane  containing  the 

;  normal  of  a  plane  and  some 
;  line  not  in  that  plana  but 
;  that  intersects  it.  If  line 
;  is  perpendicular  to  the  plane 
;  it  will  be  a  vertical  plane. 

(let*  ((point-intersect  (find-intercept-point  facet  line-1)) 

(line-N  (normal-line  point- intersect  facet) ) 

(end-point-on-normal-line 
(vector-end-point  (oval 

(line-aagment-direction-vector  (aval  line-N) ) ) ) ) ) 

(cond  ((parallel-lines  line-N  line-1) 

(return-from  make-a-path-plane  (make-vertical-plane  line-1))) 

(t  (make-a-plane  end-point -on-normal -line  line-1))))) 


126 


(defun  angle -bet ween-1 ine-f ace tN  (line-1  facet)  ;  finds  the  angle  between 

;  line-1  and  the  normal 
;  of  plane,  line-1  and  plane 
;  must  intersect 
#  0  is  perpendicular  to  plane 

(let*  ( (point-intersect  (find-intercept-point  facet  line-1)) 

(line-N  (normal-line  point-interaect  facet) ) 

(angle  ' nil) ) 

(cond  ( (parallel-lines  line-N  line-1) 

(return-from  angle-between-line-facetN  '0)) 

(t  (setf  angle  (angle-between-lines  line-N  line-1)))) 

(cond  ((GT  angle  *PI2*) 

(setf  angle  (-  *PI*  angle)))) 
angle) ) 


(defun  angle -bet ween -lines -smallest  (LI  L2) 
(let  ((angle  (angle-between-lines  LI  L2))) 
(cond  ( (GT  angle  *PI2*) 

(setf  angle  (-  *PI*  angle)))) 
angle) ) 


(defun  f ind-snells-angle  (Line-1  Facet  Cost-1  Coat-2) 

;  Finds  outbound  snells  angle  assuming 


sin (theta-2) 


;  Cost-1  *  sin (theta-1)  «  Cost-2  * 


and 


where  theta-x  is  the  angle  between  line 


,  tne  normal  to  the  plane 
/  Line-1  MOST  intersect  Facet 
(let  ((theta-1  (angle-between-line-facetN  line-1  facet)) 
(theta-2  'nil)  " 

(temp) ) 

(cond  ((zerop  Cost-1) 

(setf  cost-1  ' .01) ) ) 

(cond  ((zerop  Cost-2) 

(setf  cost-2  '.01))) 

(cond  ((zerop  theta-1) 

(return-from  find-snells-angle 
(  (equal  Cost-1  Cost-2) 

(return-from  find-snells-angle  theta-1) ) 

(t  (setf  temp  (/  (*  Cost-1  (sin  theta-1)) 

(terpri)  (princ  ten?))  (terpri) 

(cond  ( (>  temp  ’1.0) 

(terpri) 

(setf  ‘reflectance*  temp) 

(princ  "Reflection  inside  volume  by  Snell 
(terpri) 


forces  going  from  0%  to  99%  to  be  within 
;  1/2  a  degree  on  perpendicular  to  plane 
ie .  shortest  path  out  of  volume 


'  0)  ) 


Cost-2) ) 


e  Law") 


(return-from  find-snells-angle  '"reflect")) 
(t  (setf  theta-2  (asin  temp)))))) 

theta-2)) 
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(defun  find-outbound- vector  (M) 

(let*  ((equl  (car  M) ) 

(equ2  (cadr  M) ) 

(A12  (firat  aqul) ) 

(B12  (second  aqul)) 

(C12  (third  aqul)) 

(dl  (first  aqu2)) 

(el  (second  equ2) ) 

(fl  (third  equ2)) 

(KO  (fourth  equ2) ) 

(tastl  (-  (*  C12  el) 

(*  B12  fl))) 

(Kl) 

<K2) 

(K3) 

(K4) 

(quad-equ) 

(d21) 

(d22) ) 

(cond  ((or  (<  (abs  tastl)  '0.00001) 

(zerop  C12))(princ  "aborted  process  -  division  by  zero") 
(terpri) (princ  "Trying  find-outbound-vector-2") (terpri) 
(return-from  find-outbound-vector  (find-outbound-vector-2  M) ) ) ) 
(setf  Kl  (/  (*  K0  C12)  testl) ) 

(setf  K 2  (/  (-  (*  A12  fl)  (*  C12  dl>)  testl)) 

(setf  K3  (/  (*  B12  Kl)  (-  C12)  ) ) 

(setf  K4  (/  (+  A12  (*  B12  K2)>  (-  C12>>> 

(setf  quad-equ  (list  (+  1  (*  K2  K2)  <*  K4  K4)) 

(+  <*  2  Kl  K2)  <*  2  K3  K4)) 

(+  -1  <*  Kl  Kl)  (*  K3  K3)  ) )  ) 

(setf  d21  (car  (solve-quadratic  quad-equ))) 

(setf  d22  (cadr  (solve-quadratic  quad-equ))) 

(cond  ( (complexp  d21) (princ  "aborted  process  -  complex  numbers") 
(terpri) (princ  "Trying  find-outbound-vector-2") (terpri) 
(return-from  f ind-outbound-vector  (find-outbound-vector-2  M) ) ) ) 

(list  (cond  ((complexp  d21)(list  nil)) 

(t  (list  d21  (+  Kl  (*  K2  d21))  (+  K3  (*  K4  d21))))) 

(cond  ((complexp  d22) (list  nil)) 

(t  (list  d22  (+  Kl  <*  K2  d22)  )  (+  K3  (*  K4  d22)  )  )  )  )  ) 


(defun  find-outbound-vector-2  (M) 
(let*  ( (equl  (car  M) ) 

(equ2  (cadr  M) ) 

(A12  (first  equl ) ) 

(B12  (secor^isqul ) ) 

(C12  (third^jul)) 

(dl  (first  equ2)) 

(el  (second  equ2) ) 

(fl  (third  equ2) ) 

(K0  (fourth  equ2) ) 

(testl  (-  (*  B12  dl) 

(*  A12  el))) 

<r.l) 

<K2) 

(K3) 

<K4) 

(quad-equ) 

(f21) 
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(f22) ) 

(cond  ((or  (<  (aba  teatl)  '0.00001) 

(zerop  B12) ) (princ  "aborted  prooaaa  -  diviaion  by  zero") 
(terpri) (princ  "Trying  find-outbound-vector-3") (terpri) 
(return-from  find-outbound-vector-2  (find-outbound-vector-3  M) ) ) ) 
(setf  K1  (/  (*  K0  B12)  teatl)) 

(aetf  K2  (/  (-  <*  C12  el)  (*  B12  f  1)  )  teatl)) 

(aetf  K3  (/  <*  A12  Kl)  (-  B12) ) ) 

(aetf  K4  (/  (+  C12  (*  A12  K2))  (-  B12) ) ) 

(aetf  quad-equ  (Hat  (+  1  (*  K2  K 2)  (*  K4  K4)) 

(+  (*  2  Kl  K2)  (*  2  K3  K4)> 

(+  -1  (*  Kl  Kl)  (*  K3  K3))>) 

(aetf  f21  (car  (aolve-quadratic  quad-equ))) 

(aetf  f22  (cadr  (aolve-quadratic  quad-equ))) 

(cond  ((complexp  f21) (princ  "aborted  proceaa  -  complex  numbera") 
(terpri) (princ  "Trying  find-outbound-vector-3”) (terpri) 
(return-from  find-outbound-vector-2  (find-outbound-vector-3  M) ) ) ) 

(list  (cond  ( (con^lexp  f21) (list  nil)) 

(t  (list  (+  Kl  (*  K2  f21) )  (+  K3  (*  K4  f21))  f21))) 

(cond  ((complexp  f22) (list  nil)) 

(t  (list  (+  Kl  <*  K2  f22) )  (+  K3  {*  K4  f22))  f22)))) 


(defun  find-outbound-vector-3  (M) 

(let*  ( (equl  (car  M) ) 

(equ2  (cadr  M) ) 

(A12  (first  equl) ) 

(B12  (second  equl)) 

(C12  (third  equl)) 

(dl  (first  equ2) ) 

(el  (second  equ2) ) 

(fl  (third  equ2) ) 

(KO  (fourth  equ2)) 

(testl  (-  (*  A12  fl) 

(*  C12  dl) ) ) 

(Kl) 

(K2 ) 

(K3) 

(K4) 

(quad-equ) 

(«21) 

(e22 )  ) 

(cond  ((or  (<  (abs  testl)  '0.00001) 

(zerop  A12) ) (princ  "aborted  process  -  division  by  zero") 
(terpri) (princ  "Nothing  else  to  try") (terpri) 

(return-from  find-outbound-vector-3  ' "div-by-zero”) ) ) 

(setf  Kl  (/  (*  K0  A12)  teatl)) 

(setf  K2  (/  (-  (*  B12  dl)  <*  A12  el))  testl)) 

(setf  K3  (/  (*  C12  Kl)  (-  A12))) 

(aetf  K4  (/  (+  B12  (*  C12  K2) )  (-  A12))) 

(setf  quad-equ  (list  (+  1  (*  K2  K2)  (*  K4  K4)) 

(+  (*  2  Kl  K2)  <*  2  K3  K4 ) ) 

(+  -1  (*  Kl  Kl)  (*  K3  K3) ) ) ) 

(setf  e21  (car  (aolve-quadratic  quad-equ))) 

(setf  e22  (cadr  (solve-quadratic  quad-equ) ) ) 


(cond  ((complexp  e21) (princ  "aborted  process  -  complex  numbers") 
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(terpri) (princ  "Nothing  else  to  try") (terpri) 
(return-from  find-outbound-vector-3  ' ( (nil) <nil) )  ))) 

(list  (cond  ((complexp  «21) (list  nil)) 

<t  (list  (+  K3  (*  K4  e21) )  *21  <+  K1  (*  K2  «21))))) 
(cond  ( (complexp  e22) (list  nil)) 

(t  (list  (+  K3  <*  K4  e22) )  e22  (+  K1  (*  K2  *22)))))) 


(dsfun  solvs-qusdratic  (QE) 

(1st  ( (intermsdi«te-sqrt-term  (-  (*  (second  QE) (second  QE)  ) 

(*  4  (first  QE) (third  QE) ) ) ) 

(sqrterm  ' 0) ) 

(cond  ((and  (>«  intermediate-sqrt-term  '-0.1) 

(<  intermediate-sqrt-term  '0)) 

;  (terpri) 

;  (princ  "*»**  SQUARE  ROOT  OF  SMALL  NEGATIVE  NUMBER  ABOUT  TO  BE  TAKEN  *»**") 
;  (terpri) 

;  (princ  "***•  NUMBER  CHANGED  TO  ZERO  TO  AVOID  COMPLEX  NUMBER  ****")  (terpri) 
(setf  intermediate-aqrt-term  '0))) 

(setf  sqrterm  (sqrt  intermediate-sqrt-term) ) 

(list  (/  (+  (-  (second  QE) )  sqrterm) (*  2  (first  QE) ) ) 

(/  (-  (-  (second  QE) )  sqrterm) (*  2  (first  QE) ) ) ) ) ) 


(defun  find-outbound-line-2  (Line  Facet  Cost-1  Cost-2) 

;  Finds  outbound  line  from  a  Facet  using 
;  anells  law  and  solving  for  three  equations 
;  Line-1  MUST  intersect  Facet 
;  check  to  make  sure  line-1  is 
;  not  perpenduclar  to  facet 

(let*  ( (point-intersect  (find-intercept -point  facet  line)) 

(line-1  (make-unit-line  point-intersect  line) ) 

(theta-in  (angle-between-line-facetN  line-1  facet)) 

(theta-out  (f ind-snells-angle  Line  Facet  Cost-1  Cost-2)) 

(path-plane  (make-a-path-pl ane  Line  Facet)) 

(equation-la  (reverse  (cons 
'  0 

(cdr 

(reverse  (send  (eval  path-plane) 

: list-coef f ) ) ) ) ) ) 

;  plane  Ax  +  By  +  Cz  *  Ao 
(equation-1  (normalize-vector  equation-la) ) 

(equation-2 ) 

(Two-equations) 

(two-vectors) 

(angle-of-new-line-with-normal-1  ' nil) 

(angle-of-new-line-with-normal-2  'nil) ) 

(cond  ( (equal  "reflect"  theta-out) 

(return-from  find-outbound-line-2  theta-out)) 

((zerop  theta-out) 

(return-from  f ind-outbound-line-2 
(make-line 

point-intersect 

(init-point 

(map  'list  '+  (send  (eval  point-intersect)  :list-format) 

(scalar-mult  ip ly 
10 

(send 

(eval ( line-segment-direction-vector  (eval  line-1))) 

: list-format ) ))))))) 
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(setf  equation-2  (append 
(aend 

(eval  (line-segment-direction-vector  (aval  line-1))) 

: liat-format) 

(liat  (oos  (-  theta-in  theta-out))))) 

(aetf  Two-equations  (liat  equation-1  equation-2) ) 

(setf  two-vectors  (f ind-outbound-vector  Two-equations)) 

(cond  ( (null (caar  two-vectors) ) 

(setf  angla-of-new-line-with-nonnal-1  nil) 

(setf  angle-of-new-line-with-normal-2  nil)) 

(t  (setf  angle-of-new-line-with-normal-1 
(angle-between-line-facetN 
(make-line 

point-interaect 

(find-point-from-coef-and-point 
point-interaect 
(car  two-vectora) ) ) 
facet) ) 

(setf  angle-of-new-line-with-normal-2 
(angle-between-line-facetN 
(make-line 

point -intersect 

(find-point-from-coef-and-point 
point-intersect 
(cadr  two-vectors) ) ) 
facet) ) ) ) 

(cond  ((and  (null  angle-of-new-line-with-normal-1) 

(null  angle-of-new-line-with-normal-2) ) 

(princ  "solution  to  outbound  line  is  complex  -  aborted") (terpri) 
(return-from  find-outbound-line-2  '"complex"))) 

(cond  ((<«=  (abs  (-  angle-of-new-line-with-normal-1  theta-out)) 

(abs  (-  angle-of-new-line-with-normal-2  theta-out) ) ) 
(return-from  find-outbound- line-2 
(make-line 
point-intersect 

(find-point-from-coef-and-point 
point -inter sect 
(car  two-vectors) ) ) ) ) 

(t  (return-from  find-outbound-line-2 
(make-line 

point -inter sect 

(find-point-from-coef-and-point 
point -inter sect 
(cadr  two-vectors) ))))))) 


(defun  find-point-from-coef-and-point  (point  coef)  ; finds  a  point  on  a  line 

;with  coef  i,  j,  k  and  point. 


(let*  (  (end-point-l  ine 

(init-point  (map  'list  '+  (aend  (eval  Point)  :list-format) 

(map  'liat  '*  '(100  100  100) 
coef) ) ) ) ) 


end-point-line) ) 
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(defun  make-unit-line  (point  line)  ;makea  a  unit  line  from  a  point 

;  parallel  to  line 

(let*  ( (unit-vector  (send  (eval  (line-segment-direction-vector  (eval  line) ) ) 
: unit-vector) ) 

(point-coord  (send  (eval  point)  : list-format) ) ) 

(make-line  point 
(init -point 

(list  (+  (first  unit-vector) (first  point-coord)) 

(+  (second  unit-vector) (second  point-coord) ) 

(+  (third  unit-vector) (third  point-coord) )))))) 


(defun  parallel-lines  (line-1  line-2)  ;  returns  't  if  parallel,  nil  if  not 
(let  ((Til  (vector-i  (eval  (line-segment-direction-vector  (eval  line-1))))) 
(Ti2  (vector-i  (eval  (line-segment-direation-vector  (eval  line  -2))))) 

(eval  (line-segment -direction-vector  (eval  line-1))))) 

(eval  (line-segment-direation-vector  (eval  line  -2))))) 

(eval  (line-segment-direction-vector  (eval  line-1))))) 

(eval  (line-segment-direction-vector  (eval  line-2))))) 


(Tjl 

<Tj2 

(Tkl 

(Tk2 

(Tval 


(vector- j 
(vector-j 
(vector-k 
(vector-k 
'nil)) 


(cond  ((and  (not  (zerop  Til))  (not  (zerop  Ti2) ) ) 
(setf  Tval  (/  Til  Ti2))) 

((and  (not  (zerop  Tjl))  (not  (zerop  Tj2))) 

(setf  Tval  (/  Tjl  Tj2))) 

((and  (not  (zerop  Tkl))  (not  (zerop  Tk2) ) ) 

(setf  Tval  (/  Tkl  Tk2) ) ) 

(t  (return-from  parallel-lines  'nil))) 

(cond  ((and  (equal  Til  (*  Tval  Ti2)) 

(equal  Tjl  (*  Tval  Tj2)  ) 

(equal  Tkl  (*  Tval  Tk2)>) 

(return-from  parallel-lines  't)) 

(t  'nil)))) 


(defun  find- intercept -point-extended  (plane  line)  ;  find  intercept  point  of  a 

;  plane  and  line  segment 
;  extended  to  reach  the  plane, 
;  if  it  exists. 

;  return  NIL  if  not  exist 

(let  ( (denom  (rationalize  (denom-in- intercept  plane  line) ) ) 

(t-intercept  'nil) 

(I-point  ' nil) ) 

(cond  ( (not  (equal-zero-p  denom) ) 

(setf  t-intercept  (rationalize  (solve-for-t 

(send  (eval  plane)  :list-coeff) 

line 

denom) ) ) 

(setf  I-point  (get-intercept -point-2-extended  line  t-intercept)))) 

I-point) ) 


(defun  get-intercept -point-2-extended  (line  t-intercept) 

;  return  the  name  of  a  valid  intercept 
;  point  without  checking  that  intercept 
;  point  is  on  the  actual  line  segment 

(let  ((I  'nil) 

(I-list  'nil)) 

(cond  (t  (setf  I-list  (vector-add-with-t 

(line-segment-direction-vector  (eval  line) ) 
(line-segment-position-vector  (eval  line) ) 
t-intercept) ) 

(setf  I  (init-point  I-list)))) 

I)  ) 
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(defun  normalize-vector  (vector) 

/takes  a  vector  i  j  k  ...  and  normalizes  these  three 
;  by  dividing  eaoh  by  sqrt(ii  +  jj  +  kk) 

(let*  (  (i  (first  vector)) 

(j  (second  vector)) 

(k  (third  vector)) 

(X  (cdddr  vector)) 

(denomonator  (sqrt  (+  (*  i  i)  {*  j  j)  (*  k  fc) ) ) ) ) 

(cons  (/  i  denomonator) (cons  (/  j  denomonator) (cons  (/  k  denomonator) 

X) ) ) ) ) 

(defun  get-adjustment-vectors  (point  facet)  /returns  unit  vectors 

;  1  -  point  to  center  of  facet  and 
;  2  -  90  deg  off  and  in  facet 

(let*  ((line-N  (make-unit-line  point 

(normal-line  point  facet) ) ) 

(line-p  (make-unit-line  point 

(make-line  point 

(facet-center 

(eval  facet))))) 

(equation-1  (append 
(send 

(eval  (line-segment-direction-vector  (eval  line-N))) 

: list-format) 

'  (0)  )  ) 

(equation-2  (append 
(send 

(eval  (line-segment -direction-vector  (eval  line-p))) 

: list-format) 

'  (0)  )  ) 

(Two-equations  (list  equation-1  equation-2) ) 

(two-vectors) ) 

(setf  two-vectors (find-outbound-vector  Two-equations)) 

(cond  ((null  (caar  two-vectors)) 

(princ  "Adjustment  vectors  returns  complex  roots") (terpri) 

(return-from  get-adjustment-vectors  "complex") > 

(t  (list  (send 

(eval  (line-segment-direction-vector  (eval  line-N))) 

: list-format) 

(car  two-vectors) ) ) ) ) ) 


(defun  check-f acet-list-against-snells-law  (line  facet-list  volume-list) 

(do* ( (start-point 

(vector-start-point  (eval  (line-segment-direction-vector  (eval  line)))) 
(vector-start -point  (eval  (line-segment -direction-vector  (eval  line))))) 

(point  (cond((uull  (find-intercept-point-extended  (car  facet-list)  line)) 
(return-from  check-facet-list-against-snells-law  'nil)) 

(t  (find-intercept-point-extended  (car  facet-list)  line) ) ) 
(cond((null  (find-intercept-point-extended  (car  facet-list)  line)) 
(return-from  check-f acet-list-against-snells-law  'nil)) 

(t  (find-intercept-point-extended  (car  facet-list)  line)))) 

(test-1  (cond ( (point-in-volume-P  point  (car  volume-list))  't) 

(t  (return-from  check-facet-list-against-snells-law  'nil))) 

(cond ( (point-in-volume-P  point  (car  volume-list))  't) 

(t  (return-from  check-facet-list-against-snells-law  'nil)))) 
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(lino  (find-outbound- line -2  (make-line  start-point  point) 

(car  facet-liat) 

( volume -probability-of-detect ion 
(aval  (car  volume-list))) 

( volume -probabi lity-of -detect ion 
(eval  (cadr  volume-list)))) 
(£ind-outbound-line-2  (make-line  start-point  point) 
(car  facet-list) 

(volume -probability-of-detection 
(eval  (car  volume-list) ) ) 

(volume -probability-of-detection 
(eval  (cadr  volume-list) ) ) ) ) 
(volume-list  (cdr  volume-list) (cdr  volume-list)) 
(facet-list  (cdr  facet-list) (cdr  facet-list))) 

((and  (null  facet-list) 

(not  (or  (null  line) 

(equal  "complex"  line) 

(equal  "reflect"  line) 

(equal  "div-by-iero"  line))))  line) 

(cond((or  (null  line) 

(equal  "complex"  line) 

(equal  "reflect"  line) 

(equal  "div-by-zero"  line) ) 

(return-from  check-facet-list-against-snells-law  ' nil) ) ) ) ) 
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;;  Mod# : Common-Lisp;  Base: 10  -*- 

*************************************************************************** 


PATH  PLANNING  D.H.  Lewis  25  Aug  88 

Modi£i#d  L.R.  MRENN  6  Mar  89 

Contains  the  flavors,  methods ,  and  functions  nessesary  to  conduct  path 


planning.  Divided  into  three  main  sections;  Flavors,  A-star 
path  planning,  and  path  optimization. 

The  flavors  section  provides  the  essential  path  and  agenda  item  flavors, 
and  their  associated  method  and  support  functions. 

The  A*  search  section  conducts  an  a*  search  of  the  volume,  minimizing 
cost  and  visibility,  and  creates  an  initial  path. 

Finally,  the  optimization  aode  optimizes  the  initial  A*  path  according 
to  anells  lav  criteria.  This  section  may  create  one  or  several  paths 

*********  ****************************************************************** 

MAIN  FUNCTIONS: 

A-STAR-SEARCH 

A-STAR-SEARCH-M 


;  OTHER  FUNCTIONS : 

;  MAKE-PATH-NAME 

;  INIT-NEW-PATH 

;  MAKE-AGENDA- ITEM-NAME 

;  INIT-AGENDA-ITEM 

;  PUT-SUCCESSORS-ON-AGENDA 

;  AGENDA-SORT-P 

;  GOAL-ON-AGENDA-P 

REMOVE-GOAL 
FIND-PATH 
PRINT-AGENDA 
EVALUATION-FUNCTION 
COST-FUNCTION 
EVAL-TURN-COST 
PRO JECT-XY 

F IND-PREVIOUS -VOLUME 
EVAL-CLIMB-DIVE 
CALC-PATH-AND-STATS 
F IND- INTERMED I ATE-FACETS 
MAKE-FACET-TO-FACET-PATH 

OPTIMIZE  PATH  FUNCTIONS: 
OPTIMIZE-PATH 
OPTIMIZE-POINT-ON-FACET 
OPTIMIZE-K-ON-LINE 
FIND-EDGE-POINTS-OF-FACET 
AGENDA-SORT -ON-K 
F IND-SNELLS -CONSTANT 


(defvar  *PD-threahold*  '0.0) 
detection 

(defvar  *PD-modif ier *  '10.0) 
(defvar  *PI‘  '3.14159) 


maximum  desirable  probability  of 
affects  effect  of  PD  on  path  planning 


(defvar  ‘path-counter*  '0) 
(defvar  *liat-of-path»*  'nil) 
(defvar  ‘agenda-counter*  '0) 


path  name  variables 

looation  of  all  instenciated  paths 

agenda  instanciations 
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(dafvar  *Turn45*  '10.0) 
(dafvar  *Turn90*  '50.0) 

4  (dafvar  ‘BigTurn*  '5000.0) 


;  coat  for  turn  of  45  degrees  or  leas 
;  ooat  for  turn  between  45  and  90  degrees 
;  ooat  for  turns  greater  than  90  degrees 


(dafvar  ‘Shallow-Climb*  '1.20) 
(dafvar  ‘Steep-Climb*  '1.80) 
(dafvar  ‘Dive*  '0.80) 

(dafvar  Ptl) 

(dafvar  Pt2) 


;  ratio  modifier  for  a  shallow  climb 
;  ratio  modifier  for  a  steep  climb 
;  ratio  modifier  for  any  dive 
;  used  by  :make-polygon-list 
;  used  by  :make-polygon-list 


(dafvar  ‘Start-fuel*  '1225) 
(dafvar  ‘Start -TAS*  '450) 
start  with 
(dafvar  ‘Fuel*) 
between  functions 
(dafvar  *TAS‘) 
functions 


;  Fuel  airaraft  will  start  with 
;  True  Air  Speed  that  the  missile  will 

;  globle  used  to  pass  fuel  remaining 

;  globle  used  to  pass  current  TAS  between 


*************************************************************************** 

FLAVORS,  METHODS,  AND  FUNCTIONS 
*************************************************************************** 


PATH  FLAVOR 


(defflavor  path 

(start -point 
end-point 
volumes 
facets 
lines 
points 
length 
total -K 

max-detect ion-probability 
ave -detect ion-probability) 

(graphic) 

:gettable-inst ance-variables 
: settable-instance-variables 
: inittable-instance-variables 
: outside-accessible-instance-variables) 


goal 

general  path  "corridor" 
"windows"  in  cooridor 
specific  path  to  follow 
turn  points  in  path 
of  current  lines 
sum  of  deviations  from 

average  of  entire  path 


snells  law  for  path 
corridor 


; - METHODS  FOR  PATHS - 

(defmethod  (path  s length)  ()  ;  find  the  total  length  of  the  path 

(let  ( (val  ' 0.0) ) 

(cond  ( (null  length) 

(loop  for  L  in  lines 

do  (setf  val  (+  val  (send  (eval  L)  :length)))) 

(setf  length  val))) 
length) ) 

(defmethod  (path  :max-detection-probability)  ()  ;  find  the  highest  PD  on  the 

path 

(let  ( (maximum  (volume-probability-of-detection  (eval  (first  volumes) ) ) ) ) 
(loop  for  V  in  (rest  volumes) 

do  (cond  ( (<  maximum  (volume-probability-of-detection  (eval  V))) 

(setf  maximum  (volume-probability-of-detection  (eval  V)))))) 

(setf  max-detection-probability  maximum))) 
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(defmethod  (path  : ave-detection-probability)  ()  ;  find  tha  weighted  average  of 

the  PD' a 

(let  ((weighted-sum  '0.0)) 

(loop  for  Counter  from  0  to  (1-  (length  volumes) ) 
do  (setf  weighted-sum 
(4  weighted-sum 

(*  (send  (eval  (nth  Counter  lines))  :length) 

(volume-probability-of-detection  (eval  (nth  Counter 

Volumes) )))))) 

(setf  ave-detection-probability  (/  weighted-sum 

(send  self  slength))) 

ave-detection-probability) ) 

(defmethod  (path  :  make-node-list)  <)  ;  used  by  graphic  mixin-flavor  to 

draw 

(loop  for  P  in  points 

collect  (reverse  (append  (list  '1)  (reverse  (send  (eval  P) 

: list-format ) ) ) ) ) ) 


(defmethod  (path  :make-polygon-list)  ()  ;  used  by  graphic  mixin-flavor  to 

draw 

(loop  for  L  in  lines 

do  (setf  Ptl  (car  (send  (eval  L)  : endpoint-list) ) ) 
do  (setf  Pt2  (cadr  (send  (eval  L)  : endpoint-list) ) ) 

collect  (list  (position-if  ' (lambda  (A)  (equal  A  Ptl))  node-list) 
(position-if  ' (lambda  (A)  (equal  A  Pt2) )  node-list)))) 

; - PATH  NAMES - 


(defun  make-path-name  ()  ;  make  a  new  name  for  a  path 

(gensym  (incf  *path-counter* ) ) 

(intern  (gensym  "path”))) 

(defun  init-new-path  (start  end  volumes  facets  lines  points  length  K)  ;make  a 
new  path 

(let  ((name  (make-path-name))) 

(set  name  (make-instance  'path 
: start -point  start 
: end-point  end 
! volumes  volumes 
: facets  facets 
: lines  lines 
spoints  points 
: length  length 
: total -K  K 

:max-detection-probability  'nil 
: ave-detection-probability  'nil) ) 

(push  name  *list-of-paths*) 
name ) ) 
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AGENDA- ITEM  FLAVOR 


(def flavor  aganda-itam 
(voluma 
cost 

evaluation 

path 

fuel 

TAS) 

0 

: get table-instance -variables 

: aattabla-lnst anca-var lablas 

rinittable-instanee-variables 

lout aide -accessible- instance -variables) 


; - AGENDA- ITEM  NAMES - 

(defun  make -agenda- item-name  () 

(gensym  (incf  ‘agenda-counter*)) 

(intern  (gensym  "agenda"))) 

(dafun  init-agenda-item  (volume  cost  evaluation  path  fuel  TAS) 
(let  ( (name  (make-agenda-item-name) ) ) 

(set  name  (make-instance  ' agenda-item 
: volume  volume 
:cost  cost 

revaluation  evaluation 
:path  path 
:fuel  fuel 
:TAS  TAS)) 

name) ) 


l  SEARCHE  S 

; 


A*  Search 


(defun  A-star-search  (Start-point  End-point  Trace-flag  Camera-flag) 
(let*  ((start-volume  (first  (locate-point-air  start-point))) 
(goal-volume  (first  (locate-point-air  end-point))) 
(successor-volumes  (volume-connected-to  (aval  start -voluma) ) ) 
(path-volumes  'nil) 

(agenda  'nil) 

(best-path) 

(ground-volumes  'nil)) 

(tarpri)  (terpri) 

(princ  "»»Begin  A-star  Search")  (terpri)  (terpri) 

(princ  "  Start  Voluma:  ")  (prinl  start-volume)  (terpri) 

(princ  ”  Goal  Voluma:  ")  (prinl  goal-volume)  (terpri)  (tarpri) 
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(cond  (trace-flag 

(tarpri)  (princ  "Search  trace  selected.  Top  five  and  bottom  five  items") 
(terpri)  (princ  "on  seach  agenda  will  be  printed.")  (terpri)  (terpri) ) 

(t  (terpri))) 

(cond  (Camera-flag 

(terpri)  (princ  "Display  the  search  as  it  progresses  has  been  selected") 
(terpri)  (princ  "reduce  and  move  the  lisp  listener  window  to”) 

(terpri)  (princ  "the  right  1/4  of  the  screen,  press  <RETURN>  when  done") 
(wait-for-keyboard-input)  (terpri)  (terpri) 

(movie-ground) 

(loop  for  V  in  (universe-volumes  ‘universe*) 

do  (cond  ((equal  'ground  (volume-composition  (eval  V))) 

(setf  ground-volumes  (adjoin  V  ground-volumes) ) ) ) ) ) 

<t  (terpri))) 

(princ  "Search”) 


;  initalize  the  search  agenda 

(setf  "fuel*  *Start-fuel*)  ;  init  ‘fuel*  for  new  path 

(setf  *TAS*  "Start -TAS*)  ;  init  *TAS*  for  new  path 

(setf  agenda  (put-successors-on-agenda 

start-volume  ;  end  of  last  path 

successor-volumes  ;  successors  to  be  added 

(init-cost  start-volume 
start-point 
trace-flag)  ;  cost 
(list  start-volume)  ;  path  to  date 

end-point  ;  goal 

agenda) )  ;  agenda  to  be  changed 

;  SEARCH  along  best  agenda  item  for  all  possible  paths 
;  until  get  to  the  goal  along  one  of  the  paths 

(loop  until  (goal-on-agenda-p  goal-volume  agenda) 
do  (princ  ".") 
do  (cond  (trace-flag 

(princ  "- - New  Agenda - - - ") 

(print -agenda  agenda) ) ) 
do  (cond  (camera-flag 

(display-movie-path  agenda  start-point  ground-volumes))) 


do  (let*  ((best-successor-volume  (first  agenda)) 

(successors-to-best  (volume-connected-to  (eval  (agenda-item-volume 

(eval  best-successor-volume) ) ) ) ) ) 
(setf  successors-to-best  (remove  'EDGE  successors-to-best)) 

(loop  for  V  in  (rest  (agenda-item-path  (eval  best-successor-volume) ) ) 
do  (setf  successors-to-best  (remove  V  successors-to-best) ) ) 

(setf  agenda  (remove  best -successor-volume  agenda) ) 

;set  *fuel*  and  *tas*  from 


best-successor-volume 

(setf  ‘fuel*  (agenda-item-fuel  (eval  best-successor-volume) ) ) 
(setf  *TAS*  (agenda-item-tas  (eval  best-successor-volume) ) ) 
(setf  agenda  (put-successors-on-agenda 

(agenda-item-volume  (eval  best-successor-volume) ) 
successors-to-best 

(agenda-item-coat  (eval  best-successor-volume) ) 
(agenda-item-path  (eval  best-successor-volume) ) 
end-point 
agenda) ) ) ) 


;  SEARCH  COMPLETED  I 
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;  find  lines  and  points  in  aaarah 


(cond  (camera-flag 

(display-movie-path  agenda  atart-point  ground-volumaa ) ) ) 

<aatf  path-volumes  (ravaraa  (find-path  goal-volume  agenda) ) ) 

;get  reaultant  path 

(aetf  beat-path  (init-new-path  atart-point 

end-point 

path-volumea 

'nil 

'nil 

'nil 

'nil 

'nil)) 

(princ  "Completed")  (terpri)  (terpri) 


(make-facet-to-facet-path  beat-path)  ;  make  initial  gu ess  at  optimal  path 

(calc-path-and-atata  beat-path)  ;  fill  out  reat  of  path  flavor  data 

(cond  (camera-flag 

(aend  (aval  beat-path)  : initialize) 

(loop  for  N  in  '(1234) 

do  (cond  ((not  (egual  N  4)) 

(aend  (aval  (nth  N  *list-of-VCRa*) )  : clear-acene) ) ) 
do  (ahow-path-4  (nth  N  *liat-of-VCRa* ) 

(nth  N  *window-atata*) 
best-path 

(first  ground-volumes) 

(nth  N  *display-stata*) ) 
do  (cond  ((not  (equal  N  4)) 

(aend  (eval  (nth  N  *list-of-VCRa* ) ) 

: display-label  best -path) ) ) ) ) ) 

be at -path) ) 
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A*  Search  with  multiple  solutions 


(defun  A-star-search-M  (Start-point  End-point  Traoe-flag  paths  Camera-flag) 
(let*  ((start-volume  (first  (looate-point-air  start-point))) 

(goal-volume  (first  (looate-point-air  end-point))) 

(successor-volumes  (volume-connected-to  (eval  start -volume) ) ) 
(path-volumes  'nil) 

(agenda  'nil) 

(patha-found) 

(ground-volumes  'nil)) 

(terpri) 

(princ  ”»»Begin  A-star  Search")  (terpri)  (terpri) 

(princ  "  Start  Volume:  ")  (prinl  start-volume)  (terpri) 

(princ  "  Goal  Volume:  ")  (prinl  goal-volume)  (terpri)  (terpri) 

(cond  (trace-flag 
(terpri) 

(princ  "Search  trace  selected.  Top  five  and  bottom  five  items") 
(terpri)  (princ  "on  seach  agenda  will  be  printed.")  (terpri)  (terpri)) 
(t  (terpri) )  ) 

(cond  (Camera-flag 
(terpri) 

(princ  "Display  the  search  as  it  progresses  has  been  selected") 
(terpri)  (princ  "reduce  and  move  the  lisp  listener  window  to") 

(terpri) 

(princ  "the  right  1/4  of  the  screen,  press  <RETURN>  when  done") 
(wait-for-keyboard-input)  (terpri)  (terpri) 

(movie-ground) 

(loop  for  V  in  (universe-volumes  ‘universe*) 

do  (cond  ((equal  'ground  (volume-composition  (eval  V))) 

(setf  ground-volumes  (adjoin  V  ground-volumes) ) ) ) ) ) 

(t  (terpri))) 


;  initalize  the  search  agenda 


(setf  ‘fuel*  *Start-fuel») 
(setf  *TAS*  *Start-TAS*) 


;  init  *fuel*  for  new  path 
;  init  *TAS*  for  new  path 


(setf  agenda  (put-successors-on-agenda 

start-volume  ;  end  of  last  path 

successor-volumes  ;  successors  to  be  added 

(init -cost  start-volume 
start-point 
trace-flag)  ;  cost 
(list  start -volume)  ;  path  to  date 

end-point  ;  goal 

agenda) )  ;  agenda  to  be  changed 


;  SEARCH  along  best  agenda  item  for  all  possible  paths 
;  until  get  to  the  goal  along  one  of  the  paths 


(loop  repeat  paths  ;  find  top  several  paths 

do  (terpri) 
do  (princ  "Search”) 

do  (loop  until  (goal-on-agenda-p  goal-volume  agenda) 

;  same  loop  as  single  search 

do  (princ  ".") 
do  (cond  (trace-flag 

(princ  " - Hew  Agenda - ") 

(print-agenda  agenda))) 
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do  (oond  (camera-flag 

(diaplay-movie-path  agenda  atert-point  ground-volumes) ) ) 
do  (let*  ( (beat-auocesaor-volume  (first  agenda)) 
(successora-to-best  (volume-connected-to 

(aval  (agenda-item- volume 

(aval  beat-auoceaaor-volume) ) ) ) ) ) 

(setf  aucceasora-to-beat  (remove  'EDGE  auccessors-to-beat) ) 
(loop  for  V  in  (rest 

(agenda- item-path 
(best-succesaor-volume) ) ) 

do  (aetf  suoceaaors-to-best  (remove  V  suooeasors-to-beat) ) ) 
(setf  agenda  (remove  beat-aueoeaaor-volume  agenda) ) 

(aetf  agenda  (put-sucoeaaors-on-agenda 
(agenda-item-volume 
(eval  best-successor- volume) ) 
suooeasora-to-best 
(agenda-item-cost 
(eval  beat-auoceaaor-volume)) 

(agenda-item-path 
(eval  beat-auoceaaor-volume)) 
end-point 
agenda) ) ) ) 

do  (cond  (camera- flag 

(display-movie-path  agenda  start-point  ground-volumes))) 

(aetf  path-volumes  (reverse  (find-path  goal-volume  agenda) ) ) 

(setf  agenda  (remove-goal  goal-volume  agenda)) 

(setf  paths-found  (adjoin  (init-new-path  start-point 

end-point 

path-volumea 

'nil 

'nil 

'nil 

'  nil 

'nil) 

paths-found) ) 

(princ  "Completed")  (terpri)  (terpri) 

(make-facet-to-facet-path  (first  paths-found)) 

(calc-path-and-stats  (first  patha-found) ) 

(cond  (camera-flag 

(send  (eval  (first  paths-found))  :initialize) 

(loop  for  N  in  '  (1  2  3  4) 

do  (cond  ((not  (equal  N  4)) 

(send  (eval  (nth  N  *liat-of-VCRs* ) )  : clear-scene) ) ) 

do  (ahow-path-4  (nth  N  *liat-of-VCRa* ) 

(nth  N  *window-atats*) 

(first  patha-found) 

(firat  ground-volumes) 

(nth  N  *diaplay-atata*) ) 
do  (cond  ((not  (equal  K  4)) 

(send  (eval  (nth  N  *list-of-VCRs* ) ) 

: display-label  (first  paths-found)))))))) 


142 


(cond  (camera-flag  '* 

(loop  for  N  in  '(1234) 

do  (cond  ((not  (equal  N  4)) 

(send  (aval  (nth  N  *list-of-VCRs*) )  :clear-scene) ) ) ) 
(loop  for  P  in  patha-found 

do  (send  (aval  P)  : initialize) 
do  (loop  for  N  in  '  (1  2  3  4) 

do  (show-path-4  (nth  H  *list-of-VCRs*) 

(nth  H  *window-stats*) 

'  P 

(first  ground-volumes) 

(nth  N  * display-stats* ) ) 
do  (cond  ( (not  (equal  N  4) ) 

(send  (aval  (nth  N  *list-of-VCRs*) ) 

: display-label  (first  paths-found) )))))) ) 


paths-found) ) 


Search  utility  functions 


agenda  manipulations 


;  for  A-STAR  search 

(defun  put-auccessora-on-agenda  (pred-volume 

succeasor-vol umes 

coat  ;  cost  so  far 

path  ;  volumes 

goal 
agenda) 

(lcop  for  V  in  successor-volume* 
do  ( setf  agenda  (adjoin 

(init-agenda-item  V  ;  name 

(+  cost  (cost-function  V  path) ) 
(evaluation-function  pred-volume 
V 

path 

^  goal) 

(adjoin  V  path)  ;  path 

♦fuel*  ;  altered  during  cost-function 

*TAS*)  ;  altered  during  cost-function 

agenda) ) ) 

(stable-sort  agenda  ♦' agenda-sort-p) ) 

(defun  agenda-sort -p  (A  B) 

(cond  ( (LT  (+  (agenda-item-cost  (eval  A)) 

(agenda-item-evaluation  (eval  A) ) ) 

(+  (agenda-item-cost  (eval  B) ) 

(agenda-item-evaluation  (eval  B) ) ) ) 

(return-from  agenda-sort-p  ' t ) ) ) 

'nil) 

(defun  goal-on-agenda-p  (goal  agenda)  ;  return  T  iff  goal  volume  is  on  the 
agenda 

(loop  for  A  in  agenda 

do  (cond  ( (equal  goal  (agenda-item-volume  (eval  A) ) ) 

(return-from  goal-on-agenda-p  'T)))) 

'nil) 
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(defun  remove-goal  (goal  agenda) 

(loop  for  A  in  agenda 

do  (cond  ( (equal  goal  (agenda -item- volume  (eval  A) ) ) 

(return-from  remove-goal  (remove  A  agenda) ) ) ) ) 

'nil) 

(defun  find-path  (goal  agenda)  ;  get  the  path  once  the  goal  ia  found 

(loop  for  A  in  agenda 

do  (cond  ( (equal  goal  (agenda-item-volume  (eval  A) ) ) 

(return-from  find-path  (agenda-item-path  (eval  A) ) ) ) ) ) ) 

(defun  print-agenda  (agenda)  ;  print  agenda  and  some/all  items  on  the 

agenda 

(terpri)  (pprint  agenda)  (terpri) 

(cond  ( (>—  10  (length  agenda)) 

(princ  "Entire  agenda:  ”)  (terpri)  ;  print  whole  agenda  if  short 
(loop  for  I  in  agenda 
do  (terpri) 
do  (describe  I) ) ) 

(t  (princ  "First  five  in  agenda:  ")  (terpri)  ;  do  first  five  and  last  five 
(loop  for  Count  in  ' (0  1  2  3  4)  ;  if  long 

do  (describe  (nth  count  agenda) ) 
do  (terpri) ) 

(terpri)  (princ  "Last  five  on  agenda:  ")  (terpri) 

(loop  for  Count  in  ' (6  5  4  3  2  1) 

do  (describe  (nth  (-  (length  agenda)  Count)  agenda)) 
do  (terpri)))) 

(terpri)  (terpri)) 


; - evaluation  and  cost  functions - 

(defun  evaluation-function  (VP  VS  path-volumes  Goal) 

(let  (/(turn-modifier  (eval-turn-cost  VP  VS  path-volumes)) 
;(altitude-modifier  (aval-climb-dive  VP  VS)) 

(PD-modifier  '1.0  )  ; (*  *PD-roodif ier* 

; (-  (volume-probability-of-detection  (eval  VS) ) 

;  *PD-threehold*) ) ) ) 

(basis-distance  (distance  (volume-arithmetic-center  (eval  VS))  Goal))) 
(setf  PD-modifier  basis-distance) ) ) 


(defun  init-cost  (VStart  start-point  trace-flag) 

(let  ((PD-modifier  (*  100 

(volume-probability-of-detection  (eval  VStart) ) 

(/  (distance  start-point 

(volume-arithmetic-center  (eval  VStart))) 

(/  450  60)  )  )  ) 

(basis-cost  (fuel-burned  (distance 

(volume-arithmetic-center  (eval  VStart) ) 
start -point ) 

(climb-angle  start-point 

(volume-arithmetic-center  (eval  VStart))) 

*fuel* 

*TAS*) ) ) 

(cond  (trace-flag 

(terpri) (princ  "The  initial  cost  of  the  search  from  the") 

(terpri) (princ  "start  point  to  the  volume  it  is  in  center  is") 

(terpri) (princ  (+  PD-modifier  basis-cost)))) 

(+  PD-modifier  basis-cost) ) ) 
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(defun  cost-function  (VS  path-volumes) 

(let  (  ; (altitude-modifier  (eval-climb-dive  (first  path-volumes)  VS) ) 

(turn-modifier  (eval-turn-coat  (first  path-volumes)  VS  path-volumes)) 
(PD-modifier  (PD-cost  (first  path-volumes) 

(volume-arithmetic-center  (eval  (first  path- volumes) ) ) 

VS 

(volume-arithmetic-center  (eval  VS) ) ) ) 

(basis-cost  (fuel-burned  (distance  (volume-arithmetic-center  (eval  VS) ) 

(volume-arithmetic-oenter  (eval  (first 

path-volumes) ) ) ) 

(climb-angle  (volume-arithmetic-oenter  (eval  (first 

path-volumes) ) ) 

(volume-arithmetic-center  (eval  VS))) 

*fuel* 

*TAS*) ) ) 

(+  turn-modifier  PD-modifier  basis-coat) ) ) 

(defun  PD-cost  (VP  VP-point  VS  VS-point) 

(let*  ((common-facet  (find-common-facet  VP  VS)) 

(straight-_ine  (make-line  VP-point  VS-point)) 

(intercept-point  (find-intercept-point  common-facet  straight-line) ) ) 

(+  (*  100 

(volume-pcobability-of-detection  (eval  VP)) 

(/  (distance  VP-point  intercept -point) 

(/  450  60))) 

(*  100 

(volume-probability-of-detection  (eval  VS) ) 

(/  (distance  VS-point  intercept-point) 

(/  450  60)))))) 

(defun  eval-turn-cost  (VP  VS  Path-volumes) 

(let  ( (pro jected-VP-center  (project-xy  (volume-arithmetic-center  (eval  VP)))) 
(pro jected-VS-center  (project-xy  (volume-arithmetic-center  (eval  VS)))) 
(previous-volume  (find-previous-volume  VP  Path-volumes)) 

(pro jected-vol-center  'nil) 

(path  'nil) 

(new-path  'nil) 

(angle-of-turn  'nil)) 

(cond  ((equal  VP  previous-volume)  ;  no  previous  path  ? 

(return-from  eval-turn-cost  '1.0)) 

(t  (setf  pro jected-vol-center  (project-xy 

(volume-arithmetic-center  (eval  previous-volume)))) 

(setf  path  (make-line  pro jected-vol-center  pro jected-VP-center ) ) 
(setf  new-path  (make-line  pro jected-VP-center  pro jected-VS-center ) ) 
(setf  angle-of-turn  (angle-between-lines  path  new-path) > 

(cond  ( (GT  angle-of-turn  (/  *PI*  '2.0)) 

(return-from  eval-turn-coat  (*  (-  angle-of-turn  90)  2))))))  ; 

turn  >  90 

*Turn45* ) )  ;  turn  <«  90 


(defun  project-xy  (Point) 

(let  ((point-coords  (send  (eval  Point)  : list-format) ) ) 

(init-point  (list  (first  point-coords)  (second  point-coords)  '0.0)))) 

(defun  find-previous-volume  (VP  path-volume) 

(let  ( (position-VP  (position  VP  path-volume) ) ) 

(cond  ((>1  (length  path-volume)) 

(return-from  find-previous-volume  (elt  (1+  position-VP) 
path-volume) ) ) 

(t  (return-from  find-previous-volume  (first  path-volume)))))) 
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(defun  eval-climb-dive  (VP  VS) 

(let*  ((inter-facet  (find-common-faoet  VP  VS)) 

(interfacet-z  (third  (mean-point-in-facet  inter-facet))) 

(path-z  (third 

(send  (aval  (volume-arithmetic-center  (aval  VP)))  : list- format) )) ) 
(cond  ((and  (LT  path-z  (*  interfacet-z  ’1.10)) 

(GT  path-z  (*  interfacet-z  '0.90))) 

(return-f rom  eval-climb-dive  '1.0))  ;  level  flight 

((GT  path-z  interfacet-z) 

(return-f rom  eval-climb-dive  *Dive*))  ;  dive 

(t  (loop  for  P  in  (aend  (aval  inter-facet)  :pointa) 

do  (cond  ((>  path-z  (third  (aend  (aval  P)  : list-format) ) ) 

;  shallow  climb 

(return-from  eval-climb-dive  *Shallow-Climb*) ) ) ) ) ) 
*Steep-Climb*) )  ;  steep  climb 


general  functions  in  support  of  path  planning' 


(defun  Calc-path-and-stats  (path)  ;  used  to  find  support  info  on  a  new 

path 

(send  (eval  path)  : length) 


;  determine  probability  limits 

(send  (eval  path)  :max-detection-probability) 

(send  (eval  path)  :ave-detection-probabillty) 

(princ  "»»Path  Statistics:")  (terpri)  (terpri) 

(princ  "  Maximum  detection  probability:  ") 

(prinl  (path-max-detection-probability  (eval  path) ) ) 

(terpri) 

(princ  "  Average  detection  probability:  " ) 

(prinl  (path-ave-detection-probability  (eval  path) ) ) 

(terpri) 

(princ  "  Total  length  of  path:  ") 

(prinl  (path-length  (eval  path) ) ) 

(terpri) 

(princ  "  Total  number  of  maneuvers:  ")  (prinl 

<-  (length  (path-points  (eval  path)))  ’ 2 )) 

(terpri)  (terpri) 

(princ  "»»Path:  ")  (prinl  path)  (terpri)  (terpri) 

'nil) 

(defun  find-intermediate-facets  (path)  ;  find  all  the  facets  along 

;  the  path 

(let  ((previous-volume  (first  (path-volumes  (eval  path)))) 

(facets  ' nil) ) 

(loop  for  V  in  (rest  (path-volumes  (eval  path))) 
do  (setf  facets  (adjoin  (find-common-facet  previous-volume  V)  facets)) 
do  (setf  previous-volume  V) ) 

(reverse  facets) ) ) 

(defun  mafce-center-to-center-path  (path) 

(let  ((last-point  (path-start -point  (eval  path))) 

(points  (path-start-point  (eval  path) ) ) 

(lines  'nil)) 

(setf  (path-facets  (eval  path))  (find- intermediate-facets  path)) 

(loop  for  V  in  (path-volumes  (eval  path) ) 
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do  (let  ( (next -point  (volume-arithmetic-center  (eval  V)))) 

(setf  lines  (adjoin  (make-line  last-point  next-point)  lines) ) 
(aetf  points  (adjoin  next-point  points) ) 

(setf  last-point  next-point) ) ) 

(push  (make-line  last-point  (path-end-point  (eval  path)))  lines) 
(push  (path-end-point  (eval  path) )  points) 

(setf  (path-lines  (eval  path) )  (reverse  lines) ) 

(setf  (path-points  (eval  path) ) 

(adjoin  (path-atart-point  (eval  path))  (reverse  points))))) 


(defun  make-facet-to-facet-path  (path) 

(let  ( (last-point  (path- start -point  (eval  path) ) ) 

(points  (path-start-point  (eval  path) ) ) 

(lines  'nil)) 

(setf  (path-facets  (eval  path))  (f ind-intermediate-facets  path)) 
(loop  for  F  in  (path-facets  (eval  path)) 
do  (let  ((next -point  (init-point  (mean-point-in-facet  F) ) ) ) 
(setf  lines  (adjoin  (make-line  last-point  next-point)  lines)) 
(setf  points  (adjoin  next-point  points)) 

(setf  last-point  next-point))) 

(push  (make-line  last-point  (path-end-point  (eval  path) ) )  lines) 
(push  (path-end-point  (eval  path) )  points) 

(setf  (path-lines  (eval  path) )  (reverse  lines) ) 

(setf  (path-points  (eval  path) ) 

(adjoin  (path-atart-point  (eval  path))  (reverse  points))))) 


(defun  get-keyboard-input  () 

(send  *terminal-io*  :tyi-no-hang) ) 


(defun  wait-for-keyboard-input  () 
(send  *terminal-io*  :tyi)) 
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******************************************************************************* 


PATH  OPTIMIZATION 

♦a***************************************************************************** 

;;  OPTIMIZE  PATH  ACCORDING  TO  SNELL'S  LAW.  D.H.  LEWIS  10/11/88 

!  * 

;;  Develop  an  expression  for  snail's  constant  at  aach  facat  along  tha 
;;  tha  path,  and  than  minimise  it  with  r aspect  to  tha  faoata  before 
;;  and  after  tha  facet  concerned.  Sum  all  constants  along  the  path 
;;  to  determine  the  net  amount  of  deviation  from  snail's  law.  Repeat 
;;  until  total  constant  minimized. 

e  e 
9  9 

**************************************************************************** *** 


(defvar  *PI2*  (/  *PI*  '2.0)) 

(defvar  ‘search-increment*  '10) 

- - MAIN  PATH  OPTIMIZATION  FUNCTION 


(defun  optimize-path  (path) 
(let  ( (new-path-pointa  (list 
(new-path-lines  'nil) 
(new-path-length  '0.0) 
(new-path  'nil) 

(last-point  'nil)  ; 

(total-K  '0.0)) 


(path-start -point  (aval  path) ) ) ) 


dummy  for  building  path  lines 
total  deviation  from  snail's  law 


;  optimize  path  point  for  each  facet  in  turn, 
;  appending  new  points  onto  new-point  list  as 
;  they  are  created 


(terpri)  (terpri) 

(princ  "Optimizing  path  ")  (prinl  path)  (princ  ":")  (terpri)  (terpri) 

(loop  for  Facet-nr  from  ' 1  to  (length  (path-facets  (aval  path) ) ) 
do  (let  (> 

(princ  "Optimizing  at  facet  number  ") 

(prinl  facet-nr)  (princ  "  :  ")  (prinl  (nth  (1-  facet-nr)  (path-facets 
(eval  path) ) ) ) 

(terpri) ) 

do  (let  ( (prev-point  'nil) 

(next-point  (nth  (1+  facet-nr)  (path-points  (eval  path)))) 

(path-point  (nth  facet-nr  (path-points  (eval  path) ) ) ) 

(new-point  'nil) 

(facet  (nth  (1-  facet-nr)  (path-facets  (eval  path)))) 

(N1  (+  '1  (volume-probability-of-detection 

(eval  (nth  (1-  facet-nr)  (path-volumes  (eval  path) )))))) 
(N2  (+  '1  ( volume-probability-of-detection 

(eval  (nth  facet-nr  (path-volumes  (eval  path) ))))))) 


;  use  "best"  previous  point  astimate 


(cond  ( (>  facet-nr  '1) 

(setf  prev-point  (first  new-path-points) ) ) 

(t  (setf  prev-point  (nth  (1-  facet-nr)  (path-points  (eval  path)))))) 

;  (pprint  (list  '"initial:  "  facet-nr  prev-point  path-point  next-point 

facet  N1  N2) ) 
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(setf  new-point  ( optimize -point -on- faoet  prev-point 

next -point 
facet 

path -point 

N1 

N2>> 

;  (pprint  (list  '"new  path  point:  "  new-point  (get  new-point  'K>)> 

(setf  new-path-points  (adjoin  new-point  new-path-pointa ) ) 

(setf  total-K  (+  total-K  (get  new-point  'K))))) 

;  add  goal  to  new  points,  draw  new  path 

(setf  new-path-points  (adjoin  (oar  (last  (path-points  (aval  Path)))) 
new-path-points) ) 

(setf  new-path-points  (reverse  new-path-points)) 

(setf  last-point  (first  new-path-points)) 

(loop  for  P  in  (rest  new-path-points) 
do  (let  () 

(setf  new-path-lines  (adjoin  (make-line  last-point  P)  new-path-lines) ) 
(setf  new-path- length  (+  (send  (eval  (first  new-path-lines))  :length) 
new-path-length) ) 

(setf  last-point  P) ) ) 

(setf  new-path-lines  (reverse  new-path-lines)) 

;  build  the  new  path  with  optimized  path  data 


(terpri)  (terpri) 

(princ  "Optimization  completed")  (terpri) 

(setf  new-path (init-new-path  (path-start -point  (eval  path)) 

(path-end-point  (eval  path) ) 

(path-volumes  (eval  path) ) 

(path-facets  (eval  path) ) 

new-path-lines 

new-path-points 

new-path-length 

total-K) ) 

(calc-path-and-stats  new-path) 
new-path) ) 


; - FIND  THE  BEST  POINT  ON  THE  FACET - 

(defun  optimize-point-on-facet  (prev-point  next-point  facet  path-point  N1  N2) 

;  Find  the  point  on  the  facet  with  the  lowest 
;  snell's  constant  (K) . 

(let*  ((straight-path-line  (make-line  prev-point  next-point)) 

(straight -path-point  (find-intercept-point  facet  straight -path-line) ) 
(path-K-line  (make-line  path-point  straight -path-point) ) 

(path-plane  (make-a-plane  prev-point  path-K-line) ) 

(list-of-pointa  (find-edge-points-of-facet  path-plane  facet))) 

;  (pprint  list-of-points) 

;  (pprint  (list  facet  straight -path-point) ) 

(setf  (get  straight-path-point  ’ K)  (f ind-snells-constant 

straight -path-point 

(make-line  straight-path-point  prev-point) 
(make-line  stiaight-path-point  next -point) 
facet 
N1 
N2 )  ) 
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;  do  apecial  caaea  firat 

(cond  ( (inaide-facat-p  atraight-path-point  faoat) 

(oond  ((equal  '0.0  (*  '1.0  (gat  atraight-path-point  'K))> 

(return-from  opt imi z e-point-on -facet  atraight-path-point)) 
(t  (aetf  liat-of-pointa  (adjoin  atraight-path-point 
liat-of-pointa) ) ) ) ) 

(t  (aetf  liat-of-pointa  (adjoin  path-point  liat-of-pointa)))) 

;  (pprint  (liat  liat-of-pointa  (length  liat-of-pointa) ) ) 

(oond  ( (<  '1  (length  liat-of-pointa)) 

(aetf  path-point  (optinise-K-on-line  liat-of-pointa 
prev-point 
next -point 
faaet 
Ml 

M2))) 

(t  (aetf  (get  path-point  'K)  (f ind-anella-oonatant  Path-point 

(make-line  Path-point  prev-point) 
(make-line  Path-point  next -point) 
faaet 
Ml 

M2)))) 

path-point) ) 


(defun  optimize-K-on-line  (agenda  prev-point  next-point  facet  N1  N2) 
(let  ((loweat-K-point  'nil) 

(beat-line  'nil) 

(mid-point  ' nil) ) 

;  (pprint  (liat  '"Optimize:  "  agenda)) 

(loop  for  P  in  agenda 

do  (aetf  (get  P  '  K)  (f ind-anella-constant  P 

(make-line  P  prev-point) 
(make-line  P  next-point) 
facet 
Ml 

M2) )  ) 

(aetf  agenda  (atable-aort  agenda  #' agenda-aort-on-K) ) 

(aetf  loweat-K-point  (firat  agenda)) 

;  (pprint  (liat  '"Sorted  optimize:  "  agenda  loweat-K-point)) 

(loop  repeat  '3 
do  (let  () 

(aetf  beat-line  (make-line  (firat  agenda)  (aecond  agenda) ) ) 

(aetf  mid-point  (init-point  (aend  (aval  beat-line)  :midpoint) ) ) 
(aetf  (get  mid-point  'K)  (find-anella-conatant  mid-point 

(make-line  mid-point  prev-point) 

(make-line  mid-point  next-point) 

facet 

N1 

N2)> 

(aetf  agenda 

(atable-aort  (liat  (firat  agenda)  (aecond  agenda)  mid-point) 
#' agenda-aort-on-K) ) 

(pprint  agenda) 

(pprint  (liat  (firat  agenda)  (get  (firat  agenda)  'K))) 

)  ) 

(firat  agenda))) 
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(defun  f ind-edge-points-of-facet  (plana  facet) 

(lat  ((intercept-points  'nil)) 

(loop  for  E  in  (facet-edges  (aval  faoat) ) 

do  (lat  ( (intarcapt-point  (find-intaroapt-point  plana  E) ) ) 
(cond  ((not  (null  intarcapt-point) ) 

(aatf  intaroapt-pointa  (adjoin  intarcapt-point 
intarcapt-points) ) ) ) ) ) 
intarcapt-pointa) ) 


(dafun  agenda-sort-on-K  (A  B)  ;  aort  by  ineraaaing  abaoluta  valua  of  K 
proparty 

«  (aba  (get  A  'K))  (aba  (gat  B  'K)))) 


■FIND  SNELLS  CONSTANT' 


(dafun  f ind-anells-conatant  (Point  Line-1  Lina-2  Facet  N1  N2) 

;  find  anella  conatant  at  a  boundary,  i.e. s 

r 

;  K  -  N1  *  sin(thata-l)  -  N2  *  sin (theta-2) 

a 

/ 

;  note:  returns  NIL  if  anything  would  "blow  this  up” 
(let*  ( (end-point-normal-line 

(init-point  (map  'list  '+  (send  (aval  Point)  :list-format) 

(map  'list  '«  '(100  100  100) 

(send  (aval  facet)  : list-coef f-3) ) ) ) ) 

(normal-line  (make-line  Point  end-point -normal-line) ) 

(perpendicular-plane 

(make-a-plane 

(init-point  (list  '0  '0  (third  (sand  (aval  point)  : list-format) )) ) 
normal-line) ) 

(line- joining-points  (make-line  (send  (eval  line-1)  :end-point) 

(send  (eval  line-2)  :end-point) ) ) 

(default  '100) 

(theta-1  (angle-between-lines  Line-1  normal-line)) 

(theta-2  (angle-between-lines  Lina-2  normal-line) ) ) 

(cond  ((and  (m  (null  Theta-1)) 

(not  (nu.  theta-2))) 

(setf  theta-1  (abs  (raalpart  theta-1))) 

(setf  theta-2  (aba  (raalpart  theta-2) ) ) 

(cond  («  *PI2*  theta-1  > 

(setf  theta-1  (-  *FI*  thata-1)))) 

(cond  («  *PI2*  theta-2) 

(setf  theta-2  (-  *PI*  theta-2) ) ) ) 

(cond  ( (>  theta-1  (raalpart  (asin  (/  N2  Nl))))  ;  critical  angle? 

(setf  theta-2  *PI2*))) 

(cond  ((send  (aval  line- joining-points)  : strattla-plane-p 
perpendicular-plane) 

(return-from 

f ind-anells-constant  (-  (*  Nl  (sin  theta-1)) 

(*  N2  (sin  theta-2) )))) 

(t  (return-from 

f ind-anells-constant  (-  (*  Nl  (ain  theta-1)) 

(*  N2  (-  (*  '2  *PI*) 

(sin  theta-1))))))))) 

default) ) 
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;;  -*-  Mod*:  Lisp  ;  Syntax  :  Common-lisp  -*- 

*************** ************************************************************* 

MAIN  CONTROL  FONCTIONS 


Thaaa  functions  perform  overall  control  of  the  static  construction 
phase  of  the  code.  They  include  the  initial  input  control  loops  (for 
both  input  methods,  and  the  control  loop  for  the  visibility  region 
construction  phase  of  the  static  construction.  The  initial  set-up 
functions  are  first,  followed  by  the  middle  phase  set-up  functions,  large 
scale  control  functions,  and  finally,  the  actual  input  methods  themselves. 

THESIS  D.  H.  LEWIS  20  OCT  68 

**************************************************************************** 

ROUTINE  TO  INPUT  A  DATA  STREAM  AND  CONSTRUCT  THE  VOLUME (S) 

THESIS/CS4452  D.H.  LEWIS  15  MAY  88 


Builds  the  standard  static  flavors  (Universe,  above,  below,  and  cameras), 
opens  and  reads  input  file,  and  carries  the  static  phase  through  making 
air  volumes  convex. 

MAIN  FUNCTIONS:  SET-UP  (METHOD  FILE) 

SET-UP -2 

OTHER  FUNCTIONS:  INITIALIZE-VOLUME 

MAKE-VOLUME-WITH-FACET-DATA 

DECREASSING-SORT-ON-X-P 

DECREASING-SORT-ON-Y-P 

PRINT-HEADER-1 

***************»*****************i»o***************************************** 


(defvar  ‘Universe*) 
static 

(defvar  ‘above*) 

(defvar  ‘below*) 

(defvar  ‘input-stream*) 
(defvar  ‘output-stream*) 
(defvar  ‘max-altitude*  '1000) 
(defvar  ‘min-altitude*  '0) 
(defvar  *not-convex-volumea* ) 


7  location  of  names  for  all  flavors  used  in 
7  construction 

7  standard  volumes  used  by  intercept  functions 
» 

7  system  name  for  non-standard  input  file 
7  system  name  for  non-standard  output  file 
;  maximum  altitude  in  Input  Method  2 
7  minimum  altitude  for  Input  Method  2 
;  flag  variable  for  Input  Method  2  which  tells 
7  which  facet  building  function (s)  to  use 


(defvar  ‘original-input-volumes*  'nil)  ,*  save  various  "states" 
(defvar  ‘convex-volumes*  'nil) 

(defvar  ‘final-visibility-regions*  'nil) 
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INITIAL  SETUP 


(defun  set-up  (Method  File) 

(print -header-1 ) 

(make-origin)  ;  make  favorite  constants 

(make-null-vector) 

(setf  * above*  (make-instance  'volume)) 

(setf  ‘below*  (make-instance  'volume)) 

(setf  *not-convex-volumes*  't) 

(setf  *done-making-new-visibility-volumea-f lag*  'nil) 

(setf  ‘precision*  '0.0025) 

(setf  ‘large-integer*  'le4) 

(setf  *list-of-error-planee*  'nil) 

(princ  ">Constanta  Initialized")  (terpri) 

(make-cameras) 

(princ  ">Camera  built")  (terpri) 

(make-movie-cameras) 

(princ  ">Movie  Camera  built")  (terpri) 

(setf  ‘Universe*  (make-instance  'Universe 
volumes 

iVolumes  ' () 

: observers  ' () ) ) 

(princ  ”>Universe  created;  reading  data  file")  (terpri)  (terpri) 

(setq  ‘input-stream*  (open  File  :direction  :input)) 

;  select  and  use  input  method 


;  create  camera 

;  create  movie  camera 
;  create  universe  for 


(cond  (  (equal  ' 1  Method)  ;  volume  oriented  input  method 

(do  ( (data  (read  *input-stream*  nil  ' done)  ;  read  all  volumes  into 

universe 


(setf  data  (read  ‘input-stream*  nil  'done)))) 

((atom  data)) 

(push  (init-volume  data)  (universe-volumes  ‘Universe*)) 

(princ  "»»  Volume  created;  ") 

(prinl  (car  *list-of-volumes* ) ) 

(princ  "  Composition:  "> 

(prinl  (volume-composition  (eval  (car  *list-of-volumes*) ) ) )  (terpri) 
(make-all-facets  (car  *list-of-volumes*) ) )  ;  make  all  facets  for  new 

volume 

(loop  for  V  in  (universe-volumes  ‘universe*) 

do  (setf  (volume-visibility  (eval  V))  'nil)))  ;  remove  ambient 

visibility 


((equal  '2  Method)  ;  facet  oriented  input  method 

(do  ((data  (read  ‘input-stream*  nil  'done)  ;  read  all  volumes  into  universe 
(setf  data  (read  *  input-stream*  nil  'done)))) 

( (atom  data) ) 

(loop  for  terrain-segment  in  data  ;  go  through  each  volume  segment 

do  (setf  (universe-volumes  *universe*) 

(append  (make-volume-with-faoet-data  terrain-segment) 
(universe-volumes  ‘universe*)))))) 

(t  (terpri)  (princ  "Error:  Method  not  implemented") 

(return-from  set-up  'Done))) 


(close  ‘input-stream*)  (terpri) 

(princ  ">Creation  complete.")  (terpri)  (terpri) 

(setf  *original-input-volumes*  (universe-volumes  ‘universe*) ) 

;  complete  initial  setup  functions 
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(f ind-all-ridges) 

(terpri) 

(make-convex-volumea) 

(setf  *not-convex-volumes*  'nil) 

(setf  ‘convex-volumes*  (universe-volumes  "universe*)) 

(terpri)  (terpri)  (princ  "Enter  observer  data  now:  ")  (terpri)  (terpri)) 


(defun  print -header-1  () 

(terpri) 

(terpri) 

(princ  »********»**********************************************************") 
(terpri) 

(princ  ”*  Volume  Creation  and  Display  VI. 1  *") 

(terpri) 

(princ  "**««*****************************************************»*********") 
(terpri) 

(terpri) ) 


INPOT  METHOD  ONE 


(defun  Initialize-volume  (Volume  Data) 
(cond 

are 

( (null  Data)  Volume) 

(x  y  z)  . 

x))) 

(t  (create-new-line  Volume  (init-point 
Data))) 


;  expects  data  as: 

;  (line  line  line  ....)  where  lines 
;  (point  point)  where  points  are; 

;  (  ( (x  y  z)  (x  y  z) )  ( (x  y  z)  (x  y 

(caar  Data) )  (init-point  (cadar 


(Initialize-volume  Volume  (cdr  Data))))) 


(defun  create-new-line  (Volume  ptl  pt2)  ;  put  points  and  lines  into  volume 

instance 

(pushnew  ptl  (volume-points  (eval  Volume) ) ) 

(pushnew  pt2  (volume -points  (eval  Volume) ) ) 

(pushnew  (init-Line  (init-vector  '"origin*  ptl)  (init-vector  ptl  pt2) ) 

(volume-Edges  (eval  Volume)))) 


INPUT  METHOD  TWO 


(defun  make-volume-with-facet-data  (data)  ;  construct  a  volume  from  a  formatted 

;  list  of  data  where  format  is: 

;  (facet  facet  facet...) 

(let  ( (terrain-facets  (build-terrain  data) ) 

(terrain-box  (make-instance  'bounding-box) )  ;  used  to  find  limits  of  data 

;  points 

(ground-volume  (init-volume  (list  (list  'ground  'nil)))) 

(air-volume  (init-volume  (list  (list  'air  'nil)))) 

(pointa-and-lines  'nil)) 


;  find  all  lines  and  points  in  terrain  facets 
(aetf  points-and-lines  (info-on-facets  terrain-facets) ) 
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;  assign  valuaa  to  air  and  ground  volumaa 

(aatf  (volume-conyosition  (aval  ground-volume))  'ground)  ;  aat 
composition 

(aatf  (volume-composition  (aval  air-volume) )  'air) 

(aatf  (volume-facets  (aval  ground-voluma) )  tarrain-f aoata)  ;  put  tarrain 
facats 

(aatf  (voluma-facata  (aval  air-voluma) )  tarrain-f acata) 

;  conatruct  top/bottom  and  aidaa  of  ground  and  air 

volumaa 


(aand  terrain-box  : conatruct -bounding-box  (firat  pointa-and-lines) ) 

(let  ((point-1  (firat  (find-point  (bounding-box-max-x  terrain-box) ; corners 
of  terrain 

(bounding- box-min-y  terrain-box) 

'nil 

(first  pointa-and-lines) ) ) ) 

(point-2  (firat  (find-point  (bounding-box-max-x  terrain-box) 

(bounding-box-max-y  terrain-box) 

'nil 

(first  pointa-and-linas) ) ) ) 

(point-3  (first  (find-point  (bounding-box-min-x  terrain-box) 

(bounding-box-max-y  terrain-box) 

'  nil 

(first  points-and-linea) ) ) ) 

(point-4  (first  (find-point  (bounding-box-min-x  terrain-box) 

(bounding-box-min-y  terrain-box) 

'  nil 

(first  pointa-and-linas)))) 

(pointa-41  (atable-aort  (find-point  'nil  ;  edges  of  terrain 

(bounding-box-min-y  terrain-box) 

'nil 

(firat  pointa-and-lines) ) 

#' decreaaing-aort-x-p) ) 

(points-12  (atable-aort  (find-point  (bounding-box-max-x  terrain-box) 

'nil 

'nil 

(firat  pointa-and-linas) ) 

#' decreaaing-sort-y— p) ) 

(pointa-23  (atable-aort  (find-point  'nil 

(bounding-box-max-y  terrain-box) 

'nil 

(firat  points-and-linea)) 

♦' decreaaing-aort-x-p) ) 

(points-34  (atable-aort  (find-point  (bounding-box-min-x  terrain-box) 

'nil 

'nil 

(first  points-and-linea) ) 

#' decreasing-aort-y-p) ) 

(top-points  'nil)  ;  top  and  bottom 

(bottom-points  'nil))  ;  points 

(loop  for  P  in  (list  point-1  point-2  point-3  point-4)  ;  find  top  points 
do  (aetf  top-points  (adjoin  (init-point  (list 

(first 

(aand  (aval  P)  : list-format) ) 

(second 

(aand  (aval  P)  : list-format) ) 
*max-altitude* ) ) 

top-points) ) ) 

(aatf  top-points  (reverse  top-points) ) 
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(aatf  ( volume- facets  (aval  air-volume) ) 

(adjoin  (make-a-faeet  top-point*) 

(volume-facets  (aval  air-voluma) ) ) ) 

(aatf  (volume-facets  (aval  air-voluma) ) 

(adjoin  (build-aide-facet  (fourth  top-pointa) 

(firat  top-pointa) 
pointa-41) 

(voluma-facata  (aval  air-voluma)))) 
(aatf  (voluma-facata  (aval  air-voluma) ) 

(adjoin  (build-aida-facat  (firat  top-pointa) 

(aaoond  top-pointa) 
pointa-12) 

(voluma-facata  (aval  air-volume) ) ) ) 
(aatf  (voluma-facata  (aval  air-voluma) ) 

(adjoin  (build-aida-facat  (third  top-pointa) 

(aacond  top-pointa) 
pointa-23) 

(voluma-facata  (aval  air-voluma) ) ) ) 
(aatf  (voluma-facata  (aval  air-voluma)) 

(adjoin  (build-aida-faoat  (fourth  top-pointa) 

(third  top-pointa) 
pointa-34) 

(voluma-facata  (aval  air-volume) ) ) ) 


;  make  top  facet 


;  make  top  aidaa 
;  and  put  in  volume 


(loop  for  P  in  (liat  point-1  point-2  point-3  point-4)  ;find  bottom  points 
do  (aatf  bottom-points  (adjoin  (init-point  (list 

(firat  (sand  (aval  P)  : list-format) ) 
(second  (send  (aval  P)  : list-format ) ) 
*min-altitude*) ) 
bottom-points) ) ) 

(satf  bottom-points  (revarsa  bottom-points) ) 

(aatf  (voluma-facata  (aval  ground-volume) ) 

(adjoin  (make-a-facet  bottom-points) 

(voluma-facata  (aval  ground- volume) )) ) 

(aatf  (volume-facets  (aval  ground-volume) ) 

(adjoin  (build-aida-facat  (fourth  bottom-points) 

(first  bottom-points) 
pointa-41) 

(volume-facets  (aval  ground-volume)))) 

(satf  (voluma-facata  (aval  ground-volume) ) 

(adjoin  (build-side-facat  (firat  bottom-points) 

(second  bottom-points) 
pointa-12) 

(voluma-facata  (aval  ground-volume) ) ) ) 

(aatf  (voluma-facata  (aval  ground-volume)) 

(adjoin  (build-side-facat  (third  bottom-points) 

(aacond  bottom-points) 
pointa-23) 

(voluma-facata  (aval  ground-volume)))) 

(aatf  (volume-facets  (aval  ground-volume) ) 

(adjoin  (build-side-facet  (fourth  bottom-points) 

(third  bottom-points) 
pointa-34) 

(volume- facets  (aval  ground- volume) ) ) ) ) 

;  complete  information  on  volumes 

(setf  points-and-lines  (info-on-faceta  (volume-f acata  (aval  air-voluma)))) 
(satf  (volume-points  (aval  air-volume) )  (firat  points-and-lines) ) 

(aatf  (volume-edges  (aval  air-voluma))  (second  points-and-lines)) 


;  make  bottom  facet 


;  make  bottom  sides 
;  and  put  in  volume 


156 


(setf  points-and-lines  (info-on-faoets 

(volume- facets  (eval  ground-volume) ) ) ) 
(aetf  (volume-points  (eval  ground-volume) )  (first  points-and-lines)) 
(setf  (volume-edges  (eval  ground-volume))  (second  points-and-lines)) 
(loop  for  V  in  (list  air-volume  ground-volume) 
do  (let  () 

(terpri)  (princ  "»»  Volume  Created:  ") 

(print  V)  (princ  "  Composition:  ") 

(prinl  (volume-composition  (eval  V) ) ) ) ) 

(list  air-volume  ground- volume) ) ) 

(defun  decreasing-sort-x-p  (A  B) 

(cond  ((>  (first  (send  (eval  A)  : list-format ) ) 

(first  (send  (eval  B)  : list-format) )))) ) 

(defun  decreasing-aort-y-p  (A  B) 

(cond  ((>  (second  (send  (eval  A)  : list-format) ) 

(second  (send  (eval  B)  : list-format) )))) ) 


COMPLETE  STATIC  PHASE 


Functions  here  complete  the  static  phase  of  construction  of  the  visibility 
regions . 

MAIN  FUNCTIONS:  SET-UP-2 

A*********************************-******************************************* 

(defun  set-up-2  ()  ;  finish  initial  setup  (after  observers  created) 

(let  ((observers  (universe-observers  ‘universe*))) 

(terpri)  (terpri) 

(princ  " - PRE-PROCESS  VISIBILITY  INFORMATION - ") 

(terpri)  (terpri) 

(loop  for  Obs  in  observers  ;divide  up  universe  by  visibilities 

do  (make-visibility-regions  Obs) ) 

(terpri)  (terpri) 

(princ  "Numeric  errors:  ")  (prinl  *list-of-error-planes‘) 

(terpri)  (terpri) 

(send  ‘universe*  : save-static-items) 

(setf  ‘final-visibility-regions*  (universe-volumes  ‘universe*) ) 

(setf  *done-making-new-visibility-volumes-flag*  't)  ;  speed  things  up 

(loop  for  Obs  in  observers  ;  find  who  can  see  what 

do  (speed-demon) 
do  (determine-visibility  Obs)) 

(terpri) (terpri) 

(princ  "Determine  Probability  of  Detection  for  visibility  volumes”) 

(terpri) 

(loop  for  V  in  (universe-volumes  ‘universe*)  ;  calc  prob  of  detection  for 
do  (probabilities-assuming-independence-or  V) )  ;  each  volume 
(terpri)  (terpri) 

(speed-demon) 

(connect-volumes)  ;  build  visibility  graph 

(terpri) ) ) 


157 


;;  -*-  Mode : Common-Lisp;  Base: 10  -*- 
******************************************************************* 
;;  VISIBILITY  AND  RIDGES 

r  t 

; ;  This  file  contains  both  the  visibility  determination  code 
; ;  and  the  ridge  creation  and  initial  air-volume  "convexizing” 

;;  code.  The  visibility  code  is  first,  followed  by  the  ridge 
; ;  code . 

;;  THESIS  D.H.  Lewis  10/11/86 

******************************************************************* 

t  t 

;;  VISIBILITY  REGIONS  D.H.  Lewis  10  Aug  88 


Contains  the  Observer  flavor;  code  for  creating  and 
manipulating  observer  data;  code  for  making  visibility 
visibility  regions;  code  for  determining  the  visibility  of 
visibility  volumes;  and  finally  code  for  finding  the  probability 
of  detection  for  the  visibility  volumes. 

Main  functions:  MAKE-VISIBILITY-REGIONS  (OBSERVER) 

DETERMINE -VISIBILITY  (OBSERVER) 

INIT-OBSERVER  (COORDINATES  EFFECTIVNESS) 
CONNECT-VOLUMES  () 

DETERMINE-VISIBILITY-1 

DETERMINE-VISIBILITY-2 

Other  functions:  MAKE -OBSERVER-NAME 
COL I NEAR -P 
FIND-T 

PROBABILITIES -AS SUMING-INDEPENDENCE-OR 

PROBAB IL I TIES-ASSUMING- INDEPENDENCE -AND 

CLEAR- VISIBILITY 

MATCH-FACET-WITH-ANOTHER-VOLUME 

SHOW-CONNECTIVITY 

CLEAR-CONNECTIVITY 

CONNECTIVITY -METRIC 

FINE-IF-VISIBILITY-LINE-BLOCKED-P 

SET-ARITHMETIC-CENTERS 

SET-ZERO-PD 


;;  *  * -ALSO  CONTAINS  RIDGE  FUNCTIONS 

******************************************************************* 


(defvar  *list-of-observers*  'nil) 
(defvar  ‘observer-counter*  '0) 


FLAVORS  USED  TO  CREATE  OR  MANIPULATE  VISIBILITY  REGIONS 


(defflavor  Observer 
(Ef fectivnese 
Position) 

(graphic)  ;  for  display 

: gett able -instance- variables 
: sett able -instance -variables 
: inittable-instance-variables 
: out side-accessible -instance -variables) 
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■METHODS  FOE  OBSERVERS 


(defmethod  (observer  /make-node-list)  <) 

(list  (ravarsa  (append  (list  '  1)  (ravarsa  (sand  (aval  position) 
/list-format) ) ) ) ) ) 

(def method  (observer  /make-polygon-list)  () 

'  < (0  0))  ) 


; - FUNCTIONS  FOR  OBSERVERS- 

(defun  make -observer -name  () 

(gensym  (incf  ‘observer-counter*) ) 
(intern  (gensym  "observer"))) 


(defun  init-observer  (coord  effectivnesa) 

(let*  ( (temp  (make-observer-name) ) 

(position  (init-point  coord)) 

(volume-location  (locate-point-air  position))) 

/which  air  volumes  contain  obs? 

(cond  ((null  volume-location)  /make  sure  not  underground 

(terpri) 

(princ  "Invalid  location  for  observer  (underground)")  (terpri) 
(return-from  init-observer  'nil))) 

(set  temp  (make-instance  'Observer 

:Ef fectivness  effectivness 
/Position  position) ) 

(pushnew  temp  *list-of -observers*) 

(setf  (universe-observers  ‘universe*)  (adjoin  temp 

(universe-observers  ‘universe*) ) ) 

temp) ) 


/  Determine  all  observer  planes,  and  make  visibility  regions 


(defun  make-visibility-regions  (observer) 

(let  (  (ground- volume s  'nil) 

(air-volumes  'nil) 

(ridges  'nil) 

(planes  'nil) 

(result-volume-list  'nil)) 

/  find  all  air, ground  volumes,  visible  ridges 

(terpri)  (terpri) 

(princ  "making  visibility  regions  for:  ") 

(prinl  observer)  (terpri)  (terpri) 

(loop  for  V  in  (universe-volumes  ‘universe*) 

do  (cond  ((equal  'ground  (volume-composition  (eval  V) ) ) 

(setf  ground-volumes  (adjoin  V  ground-volumes) ) 

(loop  for  L  in  (volume-edges  (eval  V)) 

do  (cond  ((equal  'ridge  (line-segment-characteristics  (eval  L) ) ) 
(cond  ((not  (colinear-p 

(observer-position  (eval  observer) ) 

L)  ) 

(setf  ridges  (adjoin  L  ridges)))))))) 

(t  (setf  air-volumes  (adjoin  (list  V)  air-volumes)) 

(setf  (universe-volumes  *universe») 

(remove  V  (universe-volumes  ‘universe*) ) ) ) ) ) 

/  make  all  visibility  limiting  planes 

(loop  for  R  in  ridges 
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do  (setf  planes 

(adjoin  (make -a -plane  (observer-position  (eval  Observer) )  R) 
planes) ) ) 

;  intersect  all  air  volumes  with  planes 
(princ  "Air  volumes:  ")  (prinl  air-volumes)  (terpri) 

(prino  "Limiting  planes  of  visibility:  ")  (prinl  planes)  (terpri)  (terpri) 
(setf  result-volume-list  (intersect-all-planes-with-volumes  planes 

air-volumes) ) 

(loop  for  V  in  result-volume-list 

do  (push  (car  V)  (universe-volumes  ‘universe*) ) ) ) 

(send  ‘universe*  : save-static-items)  ;  save  the  state  of  the  static  model 

(universe-volumes  ‘universe*)) 

(defun  colinear-p  (point  line) 

(let  (  (tx  (find-t  '0  point  line))  ;  find  x,y,  z  t  parameters 

(ty  (find-t  ' 1  point  line) ) 

(tz  (find-t  '2  point  line)) 

(t-list  'nil) 

(t-list-reduoed  'nil)) 

(setf  t-list  (substitute  '0.0  'nil  (list  tx  ty  tz) ) ) 

(setf  t-list-reduced  (remove  'nil  (list  tx  ty  tz))) 

(cond  ((equal  '1  (length  t-list-reduced)) 

(return-from  colinear-p 

(apply  'and  (mapcar  'equal-error  (send  (eval  point)  : list-format-real) 

(send  (eval  line)  :backsubs  t-list))))) 
((equal  '2  (length  t-list-reduced)) 

(return-from  colinear-p  (apply  'equal-error  t-list-reduced))) 

(t  (return-from  colinear-p  (and  (equal-error  tx  ty) 

(equal-error  tx  tz) )))))) 


(defun  find-t  (nr  point  line) 

(let  ( (denom  (nth  nr  (send  (eval  (line-segment-direction-vector 

(eval  line)))  : list-format) ) ) 
(numerator  (-  (nth  nr  (send  (eval  point)  : list-format) ) 

(nth  nr  (send  (eval  (line-segment-position-vector 
(eval  line)))  : list-format) ))) ) 

(cond  ( (equal-zero-p  denom) 

(return-from  find-t  ’nil)) 

(t  (return-from  find-t  (/  numerator  denom)))))) 


;  Determine  visibility  of  visibility  regions 


(defun  determine-visibility  (observer) 

<determine-visibility-l  observer) ) 

(defun  determine-visibility-1  (observer) 

;  determine  the  visibility  status  (yes  or  no) 
;  of  all  air  volumes  w/  respect  to  a  sigle 

observer 

;  using  a  fast  method 

(terpri)  (terpri) 

(princ  "Visibility  determination  for:  ")  (prinl  observer) 

(terpri)  (terpri) 

(let  ((ground-volumes  'nil) 

(air-volumes  'nil) 

(ground-facets  'nil) 

( volumes -containing-observer 

(locate-point-air  (observer-position  (eval  observer) ) ) ) ) 
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;  find  all  air, ground  volumes,  and  ground  facets 
;  male  a  bounding  boxes  for  ground  facats 


(set-arithmetic-centers) 

(loop  for  V  in  volumes-containing-observer 
do  (princ  "  ") 

do  (prinl  V) 
do  (princ  "  viaibla") 
do  (tarpri)  ) 

(loop  for  V  in  (universe-volumes  ‘universe*) 

do  (cond  ( (equal  'air  (volume-coiqposition  (aval  V)  > ) 

(cond  ( (not  (member-p  V  volumes-containing-observer) ) 

(setf  air-volumes  (adjoin  V  air-volumes) ) ) ) ) 

(t  (setf  ground-volumes  (adjoin  V  ground-volumes) ) 

(loop  for  F  in  (volume-facets  (aval  V) ) 

do  (setf  ground-facets  (adjoin  F  ground-facets)))))) 

;  build  bounding  box  for  ground  facats 


(loop  for  F  in  ground- facets 

do  (send  (eval  F)  : construct -bounding-box  (sand  (aval  F)  : points) ) ) 

;  determine  visibility  of  all  air  volumes 
;  containg  the  observer 

(loop  for  V  in  volumes-containing-obaerver 
do  (setf  (volume-visibility  (aval  V) ) 

(adjoin  observer  (volume-visibility  (eval  V) ) ) ) ) 

;  determine  visibility  of  remainder  of  air  volumes 
;  by  seeing  if  visibility  line  intersects  a  ground 
;  facet 


(loop  for  V  in  air-volumes 

do  (let  ((visibility-line  (make-line  (observer-position  (eval  observer)) 

(volume-arithmetic-center  (eval  V) ) ) ) 

(blocked-flag  'nil)) 

(loop  for  F  in  ground-facets 

do  (let  ((facet-plane  (init-plane  (send  (eval  F)  ! list-coef f ) ) ) 

(I  'nil)) 

(cond  ( (subs-line-into-plane-equation  visibility-line 

facet-plane) ) 

((not  blocked-flag) 

(cond  ((send  (eval  visibility-line)  : strattle-plane-p 

facet-plane) 

(setf  I  (find-intercept-point  facet-plane 

visibility-line) ) 

(cond  ((send  (eval  F)  : inside-bounding-box-p  I) 

(cond  ( <inside-facet-p  I  F) 

(princ  "  ”)  (prinl  V) 

(princ  "  not  visible")  (terpri) 

(setf  blocked-flag  ' t) ))))))))) ) 

(cond  ( (not  blocked-flag) 

(princ  "  ”)  (prinl  V)  (princ  "  visible")  (terpri) 

(setf  (volume-visibility  (eval  V) ) 

(adjoin  observer  (volume-visibility  (eval  V)))))))) 

(terpri) 

'nil)  ) 
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(defun  determine-visibility-2  (observer) 

;  determine  tha  visibility  status  (yas  or  no) 

;  of  all  air  volumsa  w/  raspact  to  a  aigla  obsarvar 
;  using  a  slow  rnsthod 

(tarpri)  (tarpri) 

(princ  "Visibility  datarmination  fors  ")  (prinl  obsarvar) 

(tarpri)  (tarpri) 

(lat  ( (ground-volumas  'nil) 

(air-volumaa  ' nil) 

(ground-facats  'nil) 

(volumes -con taining-obsarvar 

(locate-point-air  (obsarvar-position  (aval  obsarvar) ) ) ) ) 

(set -arithmetic-canters) 


;  determine  visibility  of  all  air  volumes 
;  oontaing  tha  obsarvar 

(loop  for  V  in  volumes-oontaining-observar 
do  (satf  (volume-visibility  (aval  V) ) 

(adjoin  observer  (volume-visibility  (aval  V) ) ) ) ) 

(loop  for  V  in  volumes-oontaining-observar 
do  (princ  "  ") 

do  (prinl  V) 
do  (princ  ”  visible") 
do  (terpri) ) 


;  find  who  rest  of  volumes  are,  and  make  list 
;  of  blocking  ground  facets.  Remove  all 
;  vertical  ground  facets. 


(loop  for  V  in  (universe-volumes  "universe*) 

do  (cond  ((equal  'air  (volume-composition  (aval  V))) 

(cond  ( (not  (member-p  V  volumes-containing-observer) ) 

(setf  air-volumes  (adjoin  V  air-volumes))))) 

(t  (setf  ground-volumes  (adjoin  V  ground-volumes) ) 

(loop  for  F  in  (volume-facets  (aval  V) ) 

do  (cond  ((and  (member-p  '0  (send  (aval  F)  : list-coef f-3 ) ) 
(>  2  (length  (remove 
'0 


(send  (aval  F)  :list-coeff-3) ) ) ) ) ) 

(t  (setf  ground-facets  (adjoin  F  ground-facets) ))))))) 

(setf  ground-facets  (remove-duplicates  ground-facets) ) 

(loop  for  F  in  ground-facets 

do  (send  (aval  F)  : construct -bounding-box  (send  (aval  F)  :points) ) ) 

;  determine  visibility  of  remainder  of  air  volumes 
;  by  seeing  if  visibility  line  intersects  a  ground 
;  facet 


(loop  for  V  in  air-volumes 

do  (let  ((visibility-line  (make-line  (observer-position  (aval  observer)) 

(volume-arithmetic-center  (aval  V) ) ) ) ) 

(cond  ( (find-if-visibility-line-blockad-p  visibility-line 

ground-facets 
ground -volumes) 

(princ  "  ")  (prinl  V) 

(princ  "  not  visible")  (tarpri)) 

(t  (princ  "  ")  (prinl  V)  (princ  "  visible")  (terpri) 

(satf  (volume-visibility  (aval  V)) 

(adjoin  observer  (volume-visibility  (aval  V) ))))))) 


'nil)  ) 
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(defun  f ind-if-viaibility-line-bloeked-p  (visibility-line 

ground-facets 
ground-volumes ) 

(loop  for  F  in  ground-facets 

do  (let  ( (intercept -point  (find-intercept-point 

(init-plane  (send  (eval  F)  : list-coeff ) ) 
visibility-line) ) 

(location-volumes  'nil)) 

(cond  ( (null  intercept -point) 

(return-from  find-if-visibility-line-bloc)ced-p  'nil)) 

((not  (send  (eval  F)  : inside-bounding-box-p  intercept -point) ) 
(return-from  find-if-viaibility-line-blooked-p  't)) 

(t  (setf  location-volumes  (locate-point  intercept -point) ) 

(loop  for  V  in  ground-volumes 

do  (cond  ( (member-p  V  location-volumes) 

(return-from  find-if-visibility-line-blocked-p  't)))) 
(return-from  f ind-if-visibility-line-blocked-p  'nil)))))) 


(defun  probabilities-assuming-independence-or  (volume) 

;  set  volume  probability  of  detection  using  an 
;  asssumption  of  indepedence  between  observers, 
;  and  an  "or"  combination  technique 

(let  (  (temp  '1.0)) 

(terpri) 

(prinl  volume)  (princ  "  has  P.D.:  ") 

(cond  ( (not  (null  (volume-visibility  (eval  volume) ) ) ) 

(loop  for  Obs  in  (volume-visibility  (eval  volume)) 

do  (setf  temp  (»  temp  (-  '1.0  (observer-ef fectivness  (eval  Obs)))))) 
(setf  (volume-probability-of-detection  (eval  volume))  (-  '1.0  temp)) 

(prinl  (-  '1.0  temp) ) ) 

(t  (setf  (volume-probability-of-detection  (eval  volume))  '0.0) 

(prinl  '0.0) ) ) ) ) 


(defun  probabilities-assuming-independence-and  (volume) 

I  set  volume  probability  of  detection  using  an 
;  asssumption  of  indepedence  between  observers, 

and 


;  an  "and"  combination  technique 


(let  ((temp  '1.0)) 

(terpri) 

(prinl  volume)  (princ  "  has  P.D.;  ") 

(cond  (  (not  (null  (volume-visibility  (eval  volume) ) ) ) 

(loop  for  Obs  in  (volume-visibility  (eval  volume)) 

do  (setf  temp  (*  temp  (observer-ef fectivness  (eval  Obs))))) 
(setf  (volume-probability-of-detection  (eval  volume) )  temp) 
(prinl  temp) ) 

(t  (setf  (volume-probability-of-detection  (eval  volume))  '0.0) 
(prinl  ' 0.0) ) ) ) ) 


(defun  set -arithmetic-centers  () 

(loop  for  V  in  (universe-volumes  ‘universe*) 

do  (setf  (volume-arithmetic-center  (eval  V))  (send  (eval  V) 
:  find-arithmetic-center) ) ) ) 


(defun  clear-visibility  ()  ;  clear  out  observer  visibility 

info 

(loop  for  V  in  (universe-volumes  ‘universe*) 

do  (setf  (volume-probability-of-detection  (eval  V))  ’nil) 
do  (setf  (volume-visibility  (eval  V))  'nil)) 

' Done) 
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;  a«t  all  air  volume  PD' a  to 


(defun  aet-zaro-PD  () 
zaro 

(loop  for  V  in  (universe-volumes  *universe*) 

do  (cond  ( (equal  'air  (volume-composition  (aval  V))) 

(aatf  (volume-probability-of-deteotion  (aval  V))  '0.0)))) 

' dona) 


********************************************************************* 

CONNECTIVITY 

********************************************************************* 


Connectivity  batwaan  volumes 


(dafun  Connect -volumes  ()  ;  oonnaot  all  air  volume*  by  facets, 

(let  ((volumes  (universe-volumes  ‘universe*))) 

(terpri) 

(tarpri)  (princ  "Connecting  volumes:”)  (terpri)  (terpri) 

(loop  for  V  in  volumes 
do  (prinl  V) 

do  (princ  "  Connected  to:  ") 

do  (setf  (volume-connected-to  (aval  V))  'nil) 
do  (cond  ((equal  'air  (volume-composition  (aval  V))) 

(loop  for  F  in  (volume-facets  (aval  V) ) 
do  (send  (eval  F)  :f ind-facat-cantar) 
do  (send  (eval  F)  :add-volume-to-left-connects  V) 
do  (let  ((match  (match-f acet-with-another-volume  F  V) ) ) 
(cond  ( (and 

(not  (null  match) ) 

(not  (equal  'ground  (volume-conpoaition  (eval 

match) ) ) y ) 


(send  (eval  F)  : add-voluma-to-right-connects  match)) 

( (null  match) 

(let*  ((volumes  (locata-point-air 

(facet-center  (eval  F) ) ) ) ) 

(loop  for  Connect-vol  in  (remove  V  volumes) 
do  (send  (eval  F) 

: add-voluma-to-right-connects  Connect-vol ) 

)))>)))) 

(loop  for  F  in  (volume-facets  (aval  V) ) 
do  (s» tf  (volume-connected-to  (aval  V) ) 

(append  (second  (facet-connects  (aval  F) ) ) 

(volume-connected-to  (eval  V) ) ) ) ) 

(setf  (volume-connected-to  (aval  V) ) 

(remove-duplicates  (volume-connected-to  (eval  V) ) ) ) 

(setf  (volume-connected-to  (eval  V)) 

(remove  'nil  (volume-connected-to  (eval  V)))) 

(«*'  f  (volume-connected-to  (eval  V)) 

(remove  V  (volume-connected-to  (eval  V)))) 

(lc.p  for  V2  in  (volume-connected-to  (eval  V) )  ;  remove  ground  volumes 

do  (cond  ((equal  'ground  (volume-composition  (eval  V2) ) ) 

(setf  (volume-connected-to  (eval  V)) 

(remove  V2  (volume-connected-to  (eval  V))))))) 

(prinl  (volume-connected-to  (eval  V) ) ) 

(terpri) ) 

(terpri) ) ) 
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(defun  match-f acet-with-another-volume  (Facet  Volume) 

;  return  the  name  of  the  unique  facet  which  la 

shared 

;  between  two  volumes,  else  return  NIL.  Volume  is 
;  assumed  to  contain  facet 
(let  ((volumes  (universe-volumes  ‘universe*))) 

(loop  for  V  in  volumes 

do  (cond  ((not  (equal  V  Volume)) 

(cond  ( (member-p  Facet  (volume-facets  (eval  V) ) ) 

(return-from  match-faoet-with-another-volume  V) ) 

((or  (member-p  V  (second  (facet-connects  (eval  Facet)))) 
(member-p  V  (first  (facet-connects  (eval  Facet) ) ) ) ) 
(return-from  match-facet-with-another-volume  V) ) ) ) ) ) 

'nil)) 

(defun  show-connectivity  ()  ;  show  how  volumes  connect 

(terpri) 

(loop  for  V  in  (universe-volumes  ‘universe*) 
do  ( let  ( ) 

(terpri)  (prinl  V) 

(princ  "  <->  ") 

(prinl  (volume-connected-to  (eval  V) ) ) ) ) ) 


(defun  clear-connectivity  ()  ;  clear  state  of 

connectivity 

(loop  for  V  in  (universe-volumes  ‘universe*) 
do  (setf  (volume-connected-to  (eval  V))  'nil)) 

' done) 

(defun  connectivity-metric  () 

(terpri) 

(loop  for  V  in  (universe-volumes  ‘universe*) 
do  (prinl  V) 

do  (princ  Connections:  ") 

do  (prinl  (length  (volume-connected-to  (eval  V)))) 
do  (princ  "  Facets:  ") 

do  (prinl  (length  (volume-facets  (eval  V)))) 

do  (cond  ((or  (equal  (length  (volume-connected-to  (eval  V))) 

(1-  (length  (volume-facets  (eval  V))))) 

(equal  (length  (volume-connected-to  (eval  V))) 

(length  (volume-facets  (eval  V)  ))  ))  ) 

(t  (princ  "  —  possible  error"))) 

do  (terpri ) ) ) 
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******** ****** ************************************ ************** ****** 

;;;  RIDGE  CREATION  AND  MANIPULATION  FUNCTIONS 

its  D.H.  LEWIS  22May8B 


;;;  Functions  to  find,  make,  and  manipulata  ridge  lines. 

;;;  Main  functions:  FIND-ALL-RIDGES  () 

;;;  LINE-IS-A-RIDGE-P  (LINE  VOLUME) 

;;;  MAKE-CONVEX-VOLUMES  () 

;;;  Other  functions:  FIND -FACETS -WHICH -CONTAIN -EDGE 
; ; ;  PUT-FACET-ON-CORRECT-SIDE 

; ; ;  FIND-OVERLAPP ING-FACETS 

;;;  FIND-HIGHEST-FACET 

; ; ;  RIDGE-LENGTH-SORT 

i  7  7 

•it******************************************************************** 


; - Make  ridges - 


(defun  find-all-ridges  ()  ;  look  for  line-segments  which  are  ridges 

(terpri)  (terpri) 

(princ  "Find  all  ridges  in  ground  terrain:  ")  (terpri)  (terpri) 
(loop  for  Volume  in  (universe-volumes  ‘universe*) 

do  (cond  ((equal  'ground  (volume-composition  (aval  Volume))) 

(loop  for  E  in  (Volume-edges  (eval  Volume)) 
do  (princ  "Ridge  check,  line:  ") 
do  (prinl  E) 

do  (cond  ( (line-is-a-ridge-p  E  Volume) 

(setf  (line-segment -characteristics  (eval  E) ) 

' ridge) 

(princ  "  —  Ridge”) 

(terpri)  ) 

(t  (setf  (line-segment -characteristics  (eval  E) ) 
'nil) 

(terpri) ))))))) 

(defun  line-is-a-ridge-p  (Line  Volume)  ;  T  if  line  is  a  ridge 
(let  ( (Facets  (f ind-facets-which-contain-edge  Line  Volume) ) 
(Edge-vertical-plane  (make-vertical-plane  Line) ) 

(Right-side-facets  'nil) 

(Highest-right-side-facet  'nil) 

(Left-side-facets  'nil) 

(Highest-left-side-facet  'nil) 

(Vertical-facets  'nil) 

(Overlapping-facets  'nil)) 


;  divide  facets  into  left  and  right  halves  based 
;  on  spacial  relationship  of  middle  point 
;  with  vertical  plane  of  Line 


(loop  for  F  in  facets 

do  (setf  (get  F  'center)  (init-point  (mean-point-in-facet  F  ))) 
do  (setf  (get  F  'opposite-points)  'nil) 

do  (let  ((side  (put-facet-on-correct-side  F  Edge -vertical -plane) ) ) 
(cond  ((not  (null  (first  side))) 

(setf  Left-side-facets  (adjoin  (first  side)  Left-side-facets) ) ) 
( (not  (null  (second  side) ) ) 

(setf  Vertical-facets  (adjoin  (second  side)  Vertical-facets))) 
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( (not  (null  (third  aide) ) ) 

(aatf  Right-aide-faeets  (adjoin  (third  aid*) 
Right-aide-facata) ) ) ) ) ) 


;  do  not  conaider  vertical  faoata  in  any  manner 

(cond  ( (not  (null  Vertical-faceta) ) 

(return-from  Line-ia-a-ridge-p  'nil))) 

;  handle  overlapping  faoata  by  creating  a  new  facet  center 
;  composed  of  average  of  faoet  point*  on  correat  aide  of 
;  poaaible  ridge  line 

(cond  ((or  (null  Left-aide-faceta) 

(null  Right-aide-facets)) 

(cond  ((null  Left-aide-faceta) 

(setf  Overlapping-faaets 

(find-over lapping-facets  Edge-vertical-plane 
Right-aide-facata) ) 

(loop  for  F  in  Overlapping-f aceta 

do  (setf  Right-side-facets  (remove  F  Right-side-facets)))) 

( (null  Right-side-faceta) 

(setf  Overlapping-facets 

(find-over lapping- facets  Edge-vertical-plan* 

Left-aide-facets) ) 

(loop  for  F  in  Overlapping-facets 

do  (setf  Left-aide-facets  (remove  F  Left-side-facets) ) ) ) ) 

(cond  ( (null  Overlapping-facets)  ;  have  an  internal  facet 

(return-from  lin*-ia-a-ridge-p  'nil))) 

(loop  for  F  in  Overlapping-facets 

do  (setf  (get  F  'center)  (init-point  (average-of-points 

(get  F  ' opposite-points) ) ) ) 

do  (let  ((side  (put-f acet-on-correot-aide  F  Edge-vertical-plane))) 
(cond  ((not  (null  (first  side))) 

(setf  Left-aide-facets 

(adjoin  (first  side)  Left-side-facets))) 

( (not  (null  (second  side) ) ) 

(setf  Vertical-facets 

(adjoin  (second  side)  Vertical-facets))) 

( (not  (null  (third  aide) ) ) 

(setf  Right-side-facets 

(adjoin  (third  side)  Right-side-facets) ))))))) 

;  reduce  lists  of  left-  and  right-  facets  to  one  facet 
;  per  side,  based  upon  z -value  of  mean  point  of  facet 
(cond  ( (<  1  (length  Left-side-facets)) 

(setf  Highest-left-side-facet  (f ind-highest-facet  Left-side-f acets) ) ) 

(t  (setf  Higheat-left-aide-facet  (first  Left-side-facets)))) 

(cond  ( (<  1  (length  Right-side-facets)) 

(setf  Highest-right-aide-facet  (f ind-highest-facet  Right-aide-facets))) 

(t  (setf  Highest -right-side-facet  (first  Right-side-facets)))) 

;  find  if  line  is  a  ridge  by  subs  right  side  mean  value 
;  into  left-side  plane  equation.  If  resultant  Z  value 
;  is  greater  than  right-side  mean  value  z-value,  have 
;  a  ridge,  else  not 

(let*  ((point  (send  (eval  (get  Highest-right-side-facet  'center)) 
:list-format) ) 

z-right-point-into-left-plan* 

(send  (eval  Highest-left-aide-f acet ) 

: f ind-z-given-xy  (firat  point)  (second  point)))) 

(cond  ((>  z-right-point-into-l*ft-plane  (third  point)) 

(return-from  line-ia-a-ridg*-p  't)) 

(t  (return-from  line-is-a-ridge-p  'nil)))))) 
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(defun  f ind- facet s-which-con tain -edge  (Edge  Volume) 

(let  < (temp  'nil)) 

(loop  for  F  in  (volume-facets  (eval  Volume)) 

do  (cond  ( (member -p  Edge  (facet-edgea  (eval  F) ) ) 

(aetf  temp  (adjoin  F  temp))))) 

temp) ) 

(defun  put-faaet-on-correct-aide  (Facet  Plane  ) 

(let*  ( (Ao  (fourth  (send  (eval  plane)  :liat-coeff ) ) ) 

(Ao-Point  (subs-point-into-equation  (send  (eval  plane)  :liat-coef f-3) 

(get  Facet  ' center) ) ) 

(Left  ’nil) 

(Vertical  'nil) 

(Right  'nil)) 

(cond  ( (ST  Ao  Ao-point) 

(puahnew  Facet  Left)) 

( (LT  Ao  Ao-point) 

(puahnew  Facet  Right) ) 

(t  (puahnew  Facet  Vertical))) 

(list  (first  Left)  (first  Vertical)  (first  Right)))) 


(defun  f ind-overlapping-faceta  (Vertical-plane  Facets) 

(let*  ( (Line-Ao  (fourth  (send  (eval  vertical -plane)  :liat-coeff ) ) ) 
(Facet-center-Ao  'nil) 

(over lapp ing- facets  'nil)) 

(loop  for  F  in  Facets 

do  (setf  facet -center- Ao  (send  (eval  Vertical-plane) 

: subs-point-into-plane 

(get  F  'center))) 

do  (loop  for  P  in  (send  (eval  F)  : points) 
do  (let  ( (Point -Ao 

(send  (eval  Vertical -plane)  : subs-point-into-plane  P))) 
(cond  ((or  (and  (GT  Line-Ao  Point-Ao) 

(LT  Line-Ao  Facet-center-Ao) ) 

(and  (LT  Line-Ao  Point-Ao) 

(GT  Line-Ao  Facet-center-Ao) ) ) 

(setf  overlapping-facets  (adjoin  F  overlapping-facets)) 
(setf  (get  F  ' opposite-points) 

(adjoin  P  (get  F  'opposite-points)))))))) 
over lapping- facets) ) 


(defun  f ind-highest-facet  (List-of-facets) 

(let  ( (highest-z  (third 

(send  (eval  (get  (first  list-of-faceta)  'center))  : list-format) ) ) 
(highest-facet  (first  List-of-facets))) 

(loop  for  F  in  (rest  List-of-facets) 
do  (let  ((z  (third  (send  (eval  (get  F  'center))  : list-format ))) ) 

(cond  ( (GT  z  highest-z) 

(setf  highest-z  z) 

(setf  highest-facet  F) ) ) ) ) 
highest-facet) ) 


; - Use  ridges  to  make  convex  air  volumes - 
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(defun  make-convex-volumes  () 
(let  ( (air-volume-liat  '()) 
(volume-list  'nil) 
(ridge-list  'nil) 
(plane-list  'nil)) 


;  intersect  all  vertical  planes  from  ridge 
;  line-segments  with  all  volume (s). 

;  Makes  all  air  volumes  convex, 

;  guaranteed . 


(terpri)  (terpri) 

(princ  "Making  air  volumes  convex:") 
(terpri)  (terpri) 


;  separata  all  air  and  ground  volumes 
;  and  find  ridge  lines 

(loop  for  V  in  (Universe-volumes  ‘universe*) 
do  (cond  ((equal  'air  (volume-composition  (aval  V))) 

(setf  air-volume-list  (adjoin  (list  V)  air-volume-list)) 

(loop  for  E  in  (volume-edges  (aval  V) ) 
do  (cond  ( (equal  ' ridge 

(line-segmant-characteristics  (aval  E) ) ) 

(setf  ridge-list  (adjoin  E  ridge-list) ) ) ) ) 

(setf  (universe-volumes  ‘universe*) 

(remove  V  (universe-volumes  *uni verse* ) ) ) ) ) ) 

;  reduce  list  of  ridge  lines,  and  construct  vertical  planes 
;  for  them.  ridges  are  sorted  by  length,  longest  first 

(setf  ridge-list  (remove-duplicates  ridge-list)) 

(setf  ridge-list  (remove  'nil  ridge-list)) 

(setf  ridge-list  (stable-sort  ridge-list  #' ridge-length-sort) ) 

(loop  for  R  in  ridge-list 

do  (setf  plane-list  (adjoin  (make-vertical-plane  R)  plane-list) ) ) 

(setf  plane-list  (reverse  plane-list)) 

(princ  "Air  volumes:  ")  (prinl  air-volume-list)  (terpri) 

(princ  "Ridge  planes:  ")  (prinl  plane-list)  (terpri)  (terpri) 

;  intersect  all  ridge  planes  with  all  air  volumes 

(setf  volume-list  (intersect-all-planes-with-volumes  plane-list 

air-volume-list) ) 

;  update  universe  with  new  volumes  created 


(loop  for  V  in  volume-list 

do  (push  (car  V)  (universe-volumes  ‘universe*) ) ) 
(universe-volumes  ‘universe*) ) ) 


(defun  ridge-length-sort  (A  B) 
(>  (send  (eval  A)  : length) 
(send  (eval  B)  : length))) 


/return  T  iff  A  >  B 
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;;  -*-  Mode:  LISP;  Syntax:  Common-lisp  -*- 
********************************************************************* 

;;  D.H.  Lewis  CS4 4 52 /THESIS  SMaySS 

»  ! 

******************************************************************** 

FLAVORS  AND  METHODS 


FLAVOR: 


Point 


;  METHODS:  : LIST-FORMAT 
three-tuple 

;  : LIST-FORMAT-REAL 

;  : LIST-FORMAT-4 

;  : PRINT 


give  the  x,y  and  z  values  as  a 

same,  in  real  number  format 
give  agraphics  4-tuple  " (x  y  z  1) 
print  info  on  point 


FLAVOR: 


Vector 


;  METHODS: 

t 

vector 

f 

3-tuple 


: LENGTH 
: UNIT-VECTOR 
: ENDPOINTS 

: LIST-FORMAT 

:  LIST- FORMAT -REAL 
: PRINT 


;  calculate  length  of  vector 
;  return  the  coeff  of  the  unit  vector 
;  give  the  names  of  the  endpoints  of  the 

;  give  the  coeffs  of  the  vector  as  a 

;  same,  execept  with  real  numbers 
;  print  coeff  values  to  output  file 


FLAVOR : 


Line-segment 


METHODS:  : ENDPOINTS 

: ENDPOINT-LIST 
: OTHER -END  (ENDPOINT) 


Return  the  endpoints  of  the  line-segment 
Return  endpoints  as  explicit  4-tuples 
Given  one  endpoint,  return  the  other 


I  -.START-POINT 

line-segment 
;  : END-POINT 

;  : LENGTH 

;  : BACKS UBS  (T-LIST) 

;  :MID-POITT 

;  : STRATTLE-PLANE-P  (PLANE) 

;  : PRINT 


Return  the  start  point  of  the 

"  "  end  point  "  " 

Find  and  return  the  length  of  the 
line-segment 

Subsitute  the  (Tx  Ty  Tz)  list  into 
the  line  equation 

Find  the  mid  point  of  the  line-segment 
;  do  the  endpoints  of  the  line-segment 
lie  on  opposite  sides  of  the  plane? 


FLAVOR:  . Plane 


METHODS : 


point 


: TEST-EQUAL  (PLANE) 
:LIST-COEFF 
:LIST-C0EFF-3 
: SUBS-POINT-INTO-PLANE 


;  Do  two  planes  have  the  same  coeffs? 

;  List  4-tuple  (X  Y  Z  Ao)  for  plane 
;  List  3-tuple  (X  Y  Z)  for  plane 
(POINT)  ;  Get  Ao  coeff  from  X,Y, Z  values  of 


: F IND-Z-GI VEN-XY  (X  Y) 
:FIND-Y-GIVEN-XZ  (X  Z) 
:FIND-X-GIVEN-YZ  (Y  Z) 
:PRINT 


Return  Z  value  of  point  in  plane 


»»  I*  It 

H  y  »»  n 


»!  If 

fl  If 


fl 

tl 


FLAVOR : 


Bounding-box 
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;  METHODS 
points 


: CONSTRUCT-BOUND ING-BOX  (POINTS) 


Build  a  3-D  limits  for  list  of 


: INSIDE-BOUNDING-BOX  (POINT)  ;  Is  tha  point  inaida  tha  limits? 

;  FLAVOR:  . Facet 

;  METHODS:  : POINTS 
;  : PRINT 

;  FLAVOR . Volume 

;  METHODS:  : MAKE-EQUAL 
;  '.CLEAR 

;  : FIND-ARITHMETIC -CENTER 

;  : MAKE-NODE -LIST 

;  : MAKE- POLYGON -LI ST 

;  : PRINT 

;  FLAVOR:  Universe 

;  METHODS:  : SAVE-STATIC-ITEMS 
;  : REVERT- STATIC- ITEMS 

********************************************************************* 

;  OTHER  FUNCTIONS:  MAKE-ORIGIN  INIT-POINT 

;  MAKE-NULL-VECTOR  INIT-NEW-POINT 

;  MAKE-POINT-NAME  INIT-VECOTR 

;  MAKE-LINE-NAME  INIT-NEW-VECTOR 

;  MAKE-VECTOR-NAME  INIT-LINE 

;  MAKE-FACET-NAME  1NIT-NEW-LINE 

;  MAKE-PLANE-NAME  INIT-PLANE 

;  MAKE -VOLUME -NAME  INIT-NEW-PLANE 

;  MAKE-ALL-FACETS  INIT-VOLUME 

;  MAKE-NEW-FACET  INIT-FACET-2 

;  MAKE-A-FACET 

;  FIND-OR -MAKE -LINE 

;  OLD-LINE-DV 

;  INITIALIZE-SEARCH 

;  SEARCH-TO-MAKE-FACET 

;  BUILD-SIDE-FACET 

;  BUILD-TERRAIN 

.******************#***********#************************************** 

(defvar  *origin*) 

(defvar  *null-vector*) 

(defvar  *one-vector*  ' (1.0  1.0  1.0  1.0)) 

(defvar  *one-vector-3‘  '(1-0  1.0  1.0)) 

(defvar  *zero-vector *  '(0.0  0.0  0.0  0.0)) 

(defvar  *zero-vector-3*  '(0.0  0.0  0.0)) 

(defvar  *max-counter-value*  ' 9999) 

(defvar  *dor<e-making-new-vis ibil it y- volumes- flag  *  'nil) 

(defvar  *list-of-points*  'nil) 

(defvar  *pointa-counter*  '0) 

(defvar  *minimum-points-counter *  '  0) 

(defvar  *list-of-vactors*  'nil) 

(defvar  *vectora-counter*  '0) 

(defvar  ‘minimum-vectors-counter *  '0) 

(defvar  *list-of-lines*  ’nil) 
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(defvar  ‘lines-counter*  '0) 

(defvar  *minimum-lines-counter‘  '0) 

(defvar  *list-of-planes*  'nil) 
(defvar  ‘planes-counter*  ' 0) 

(defvar  ‘minimum-planes-counter*  '  0) 

(defvar  *list-of-f acets*  '  () ) 

(defvar  *f acets-counter*  '0) 

(defvar  ‘minimum-facets-counter*  '  0) 


(defvar  *list-of-volumea*  '()) 

(defvar  ‘volumes-counter*  '0) 

(defvar  ‘minimum- volumes -counter*  '0) 


. - POINT - 

(defflavor  point 
(x-coord 
y-coord 
z -coord) 

0 

: get table -instance -variables 
: settable-instance -variables 
: inittable-instance-variables 
: out side -accessible- instance -variables) 

(defmethod  (point  : List-format )  ()  ;  return  a  3-tuple  "(X  Y  Z)" 

(list  x-coord  y-coord  z-coord) ) 

(defmethod  (point  : List-format-real )  ()  ;  return  a  real  valued  3-tuple 

(map  'list  '*  (list  x-coord  y-coord  z-coord) 

(make-list  3  : initial-element  '1.0))) 

(defmethod  (point  :List-format-4 )  ()  ;  return  list  in  graphics  format 

(list  x-coord  y-coord  z-coord  '1)) 

(defmethod  (point  :print)  () 

(pprint  (list  x-coord  y-coord  z-coord)  ‘output-stream*)) 


- - VECTOR - 

(defflavor  vector 
(i 
j 

k 

Start -point 
End-point ) 

() 

: get table- instance -variables 
: set table -in stance- var iables 
: inittable-instance-variables 
: out side -accessible -in stance -var iables ) 

(defmethod  (vector  : length)  ()  ;  Calculate  the  length  of  a  vector 

(sqrt  (abs  (+  (*  i  i)  (*  j  j)  (*  k  k))))) 
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(defmethod  (vector  : unit-vector)  ()  ;  make  a  unit  vector  from  a  vector 

(let  ((vector-length  (aend  self  :length))) 

(cond  ( (equal-zero-p  vector-length)  '(0.0  0.0  0.0)) 

(t  (map  'list  '/  (aend  aelf  : liat-format) 

(make-liat  3  : initial-element  vector-length) ) ) ) ) ) 


(defmethod  (vector  :endpointa)  ()  ; 

(liat  Start-point  End-point) ) 

(defmethod  (vector  : liat-format)  () 

(liat  i  j  k) ) 


find  the  endpointa  of  the  vector 


;  return  the  valuea  of  the 
;  vector  aa  a  3-tuple 


(defmethod  (vector  : liat-format-real)  ()  ;  return  a  real  valued  3-tuple 

(map  'liat  '*  (liat  i  j  k)  (make-liat  3  s initial-element  '1.0))) 


(defmethod  (vector  :print)  () 

(pprint  (liat  i  j  k  Start-point  End-point)  *output-atream*) ) 


■LINE  SEGMENT 


(defflavor  line-aegment 
(t-max 

poa it ion- vector 
direction-vector 
char act eria tics) 

0 


;  position  vector  can  point  to  either  end  of 
direction  vector,  direction  vector  can  point 
in  either  direction  between  endpoints 

ridge,  valle*  etc 


: gettable-instance-variables 
: settable-instance-variables 
sinittable-instance-variables 
: outside-accessible-instance-variables) 


(defmethod  (line-segment  : endpointa)  ()  ;get  endpoints  of  the  line  segment 
(send  (eval  direction-vector)  : endpoints)) 

(defmethod  (line-segment  : endpoint-list )  ()  ;  get  endpoints  in  graphics  format 

(list  (send  (eval  (car  (send  self  : endpoints) ) )  : list-format-4 ) 

(send  (eval  (cadr  (send  self  :endpoints ) ) )  : list-format-4 )) ) 

(defmethod  (line-segment  :other-end)  (endpoint) 

;  find  the  endpoint  of  the  line-segment 
;  opposite  of  the  given  endpoint 
(let  ((line-endpoints  (send  self  : endpoints) ) ) 

(cond  ((equal  endpoint  (first  line-endpoints)) 

(second  line-endpoints) ) 

(t  (first  line-endpoints))))) 

(defmethod  (line-segment  :start-point)  () 

;  what  is  the  start  point  of  the  line-aegment? 
(vector-start-point  (eval  direction-vector))) 

(defmethod  (line-segment  :end-point)  () 

;  what  is  the  end  point  of  the  line  segment? 
(vector-end-point  (eval  direction-vector) ) ) 

(defmethod  (line-segment  : length)  ()  ;  how  long  is  the  line-segment? 

(send  (eval  direction-vector)  :length)) 

(defmethod  (line-segment  :backsubs)  (t-list)  ;  subs  a  list  of  t-parameters 

;  back  into  the  line  equation  to  get 
;  the  (x  y  z)  coord  of  the  point 
(mapcar  '+  (send  (eval  position-vector)  : list-f ormat-real ) 
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(mapcar  '  *  t-liat 

(sand  (aval  direction-vector)  : list-format -real) )) ) 

(defmathod  (line-segment  :midpoint)  () 

(let  ((t-half  (/  t-max  '2.0))) 

(send  self  :backsubs  (list  t-half  t-half  t-half)))) 

(defmathod  (line-segment  : strattle-plane-p)  (plane) 

;  return  T  iff  the  endpoints  of  self 
;  are  on  opposite  sides  of  the  given 

plane 

(let  ( (Ao-1  (send  (aval  plane)  spoint-into-equation 

(first  (send  self  sendpoints) ) ) ) 

(Ao-2  (send  (eval  plane)  :point-into-aquation 

(second  (send  self  s endpoints) )) ) 

(Ao  (fourth  (send  (eval  plane)  : list-coeff ) ) ) ) 

(cond  ((or  (equal-error  Ao  Ao-1) 

(equal-error  Ao  Ao-2) ) 

'nil) 

( (or  (and  (GE  Ao-1  Ao) 

(LE  Ao-2  Ao)  ) 

(and  (LE  Ao-1  Ao) 

(GE  Ao-2  Ao) ) ) 

't)))) 

(defmathod  (line-segment  : print)  () 

(pprint  t-max  ‘output-stream*) 

(pprint  (list  position-vector  (send  (eval  position-vector)  : list-format) 
(send  (eval  position-vector)  rendpoints))  *output-stream*) 

(pprint  (list  direction-vector  (send  (eval  direction-vector)  : list-format) 
(send  (eval  direction-vector)  :endpoints))  ‘output -stream*) 

(pprint  (send  self  : endpoints)  ‘output-stream* ) 

(pprint  characteristics  ‘output- st ream* ) ) 

; - PLANE - 


(defflavor  plane 
(a-coef 
b-coef 
c-coef 
Ao) 

0 

: gettable-instance-variables 

be  a 

: settable-instance-variables 
ambiguity 

: inittable-instance-var iables 


;  uses  equation  of  plane: 
aX  +  bY  +  cZ  «  Ao 

for  comparisions,  equation  is  generally 
normalized,  so  Ao«-l,+l  or  0. 

;  NOTE:  first  non-zero  coeff  will  ALWAYS 

;  positive  number.  Avoids  direction 


:  out side -accessible-instance -variables) 


(defmethod  (plane  :test-equal)  (F2)  ;  test  plane  for  equality  by  comparing 

;  coefficients,  or  comparing  the  coeffs 
;  of  the  unit  normal  vectors 

(let  ((VI  (init-vector  '‘origin*  (init-point  (send  self  : list-coef f-3)  )  )  ) 
(V2  (init-vector  '‘origin*  (init-point  (send  (eval  F2)  :  list-coeff-3) ) ) ) ) 

(or  (apply  'and 

(map  st  t ' equal-error 

(send  self  :list-coeff) 

(send  (eval  F2)  :list-coef f ) ) ) 

(apply  'and 

(map  'list  ♦' equal-error 

(send  (eval  VI)  :unit-vector ) 

(send  (eval  V2)  :unit-vector ) ) ) ) ) ) 
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(defmethod  (plane  rlist-coeff)  ()  ;  list  plane  coefficenta  as  a  4-tuple 
(list  a-coef  b-coef  c-coef  Ao) )  ;  (includes  the  Ao  constant  term) 

(defmethod  (plane  : list-eoeff-3)  ()  ;  list  only  the  x,y,z  coefficents 

(list  a-coef  b-coef  c-coef)) 

(defmethod  (plane  :subs-point-into-plane)  (Pt)  ;  subs  a  point  into  the  planar 

;  equation,  returns  result, 
(apply  '+  (map  'list  '*  (send  self  s list-coef f-3) 

(send  (eval  Pt)  : list-format) )) ) 

(defmethod  (plane  :point-into-equation)  (point)  ;  subs  point  into  plane 
equation 

;  same  as  above 

*****REMOVE**** 

(apply  '+  (map  'list  '*  (send  (eval  point)  : list-format) 

(send  self  :  list-coeff-3) ) ) ) 


(defmethod  (plane  : f ind-x-given-yz)  (y  z) 
the 

(cond  ( (equal-zero-p  a-coef)  '0)  ;  y 

J 

(t  (/  (-  Ao  (+  (*  b-coef  y)  (*  c-coef 

(defmethod  (plane  :find-y-given-xz)  (x  z) 
the 

(cond  ((equal-zero-p  b-coef)  '0)  ;  x 

(t  (/  (-  Ao  (+  (*  a-coef  x)  (*  c-coef 

(defmethod  (plane  : f ind-z-given-xy )  (x  y) 
the 

(cond  ((equal-zero-p  c-coef)  '0)  ;  x 

(t  (/  (-  Ao  (+  (*  a-coef  x)  (*  b-coef 

(defmethod  (plane  :print)  () 

(pprint  (send  self  :list-coeff)  *output- 


;  find  the  x  value  of  a  point  given 

and  z  coordinates  of  a  point,  for 
the  plane  under  consideration 
z)))  a-coef)))) 

;  find  the  y  value  of  a  point  given 

and  z  coordinates  of  a  point,  for 
the  plane  under  consideration 
z)))  b-coef)))) 

;  find  the  z  value  of  a  point  given 

and  y  coordinates  of  a  point,  for 
the  plane  under  consideration 
y)>)  c-coef) ) ) ) 


stream*) ) 


; - BOUNDING  BOX - 

(defflavor  Bounding-box  ;  generalized  bounding  box  flavor 

(max-x 
min-x 
max-y 
min-y 
max-z 
min-z ) 

0 

:gettable- instance -variables 
: settable-instance -variables 
: inittable-instance-variables 
rout aide -accessible- instance-variables 
: required-methods) 
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(def method  (bounding-box  : construct-bounding-box)  (points) 

;  build  bounding  box  for 
;  a  list  of  points 

(1st*  ((first-point  (ssnd  (svsl  (first  points))  : list-format ) ) 

(x  (first  first-point)) 

(y  (sscond  first-point) ) 

(x  (third  first-point))) 

(sstf  max-x  x) 

(sstf  min-x  x) 

(sstf  max-y  y) 

(sstf  min-y  y) 

(sstf  max- z  z) 

(sstf  min-z  z) 

(loop  for  P  in  (rsst  points) 
do  (1st*  ( (nsxt-point  (ssnd  (svsl  P)  : list-format) ) 

(naw-x  (first  nsxt-point)) 

(new-y  (sscond  nsxt-point) ) 

(new-z  (third  nsxt-point))) 

(cond  ( (GT  new-x  max-x) 

(sstf  max-x  new-x) ) 

( (LT  naw-x  min-x) 

(sstf  min-x  naw-x) ) ) 

(cond  ( (GT  nsw-y  max-y) 

(sstf  max-y  nsw-y) ) 

( (LT  nsw-y  min-y) 

(sstf  min-y  naw-y) ) ) 

(cond  ( (GT  nsw-z  max-z) 

(sstf  max-z  nsw-z) ) 

( (LT  naw-z  min-z) 

(sstf  min-z  naw-z))))))) 

(dofmsthod  (bounding-box  : insids-bounding-box-p)  (point) 

;  raturn  T  if  point  is  insids 
>  bounding  box,  MIL  othsrwise 

(let  ( (p  (map  'list  '*  (send  (aval  point)  : list-format)  ’(1.0  1.0  1.0)))) 
(cond  ((and  (and  (GE  max-x  (first  p) ) 

(LE  min-x  (first  p) ) ) 

(and  (GE  max-y  (sscond  p) ) 

(LE  min-y  (second  p) ) ) 

(and  (GE  max-z  (third  p) ) 

(LE  min-z  (third  p) ) ) ) 

't) 

(t  'nil) ) ) ) 


, - FACET - 

(defflavor  facet 
(edges 
canter 
connects) 

(V2 . .Vm> ) " 

(plane 

bounding-box) 

: gsttable-instance-variables 
: ssttable-instancs-var iables 
! inittabls-instancs-variablss 
: out side -access ibis- instance -variables 
: required-methods) 


; list  of  all  edges  bounding  facet 
;  location  of  center  of  facet 
;  volumes  which  facet  connects  ”((Vl..Vn) 

;mixin  flavors 
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(defmethod  (facet  spoints)  ()  ;  return  all  vertlalea  of  facet 
(let  ((temp  'nil)) 

(loop  for  E  in  Edges 

do  (aetf  temp  (append  temp  (send  (aval  E)  :endpointa) ) ) ) 

(delete-duplicatea  temp) ) ) 

(defmethod  (facet  : find-facet-center)  ()  ;  find  the  average  of  all  the  vertices 

;  of  the  facet. 

(let*  ((points  (send  self  :points) ) 

(temp-sum  (send  (eval  (first  points))  : list-format) ) 

(nr-points  (length  points))) 

(loop  for  P  in  (reat  points) 
do  (setf  temp-sum  (map  'list  '  +  temp-sum 

(send  (eval  P)  : list-format) )) ) 

(aetf  (facet -center  self) 

(init-point  (map  'list  '/  temp -sum  (make-list  3  : initial -element 
nr-points) ) ) ) 

(facet-center  aelf ) ) ) 

(defmethod  (facet  :add-volume-to-left-connecta)  (V)  j  add  a  volume  to  the  left 
list 

;  of  the  connects  variable 

(cond  ((null  (facet-connects  self)) 

(setf  (facet-connects  self)  (list  (list  V)))) 

((not  (member-p  V  (first  (facet-connects  self)))) 

(setf  (first  (facet-connects  self))  (adjoin  V  (first  (facet -connects 
self))))))) 


(defmethod  (facet  :add-volume-to-right -connects)  (V)  ;  add  a  volume  to  the  right 
list 


;  of  the  connects 


variable 

(cond  ((equal  '1  (length  (facet-connects  self))) 

(setf  (facet-connects  self)  (list  (first  (facet-connects  self))  (list  V) ) ) ) 
( (not  (member-p  V  (second  (facet-connects  self) ) ) ) 

(setf  (second  (facet-connects  self) ) 

(adjoin  V  (second  (facet-connects  self))))))) 


(defmethod  (facet  :print)  () 

(pprin-  (list  edges  center  connects  (send  self  : list-coef f ) ) 


‘output-stream* ) ) 


-VOLUME- 


(defflavor  volume 
(Visibility 

Probability-of -detect ion 

Composition 

Points 

Edges 

Facets 

Arithmetic-center 
connect ed-to) 

(Graphic) 

: get table- instance -variables 
: settable-instance-variables 
: ini t table -instance- variables 
: out side -accessible- instance - 
:  required-methods) 


visible  observers 

sum  of  PD  for  observers 

ground,  air,  etc 

all  vertices  of  the  volume 

all  line-segments  of  the  volume 

all  surfaces  of  the  volume 

numeric  average  of  the  points 

adjacent  volumes 

for  3-D  projection 


variables 


177 


(defmethod  (volume  :make-equal)  (new-volume-name) 

;  make  a  new  volume  with  same 


instances 

(let  ( (temp  new-volume-name) )  ;  as  self 

(set  temp  (make-instance  'volume 

Visibility  Visibility 

:Probability-of -detect ion  Probability-of -detect ion 
: Composition  Composition 
:Points  Points 
s Edges  Edges 
: Facets  Facets 

s arithmetic-center  Arithmetio-aenter 
:oonnected-to  Connected-to) ) ) ) 


(defmethod  (volume  : clear)  ()  ;  clear  out  old  values  of  an  existing  volumes 

(setf  Visibility  'nil) 

(setf  Probability-of-detection  'nil) 

(setf  Composition  'nil) 

(setf  Points  'nil) 

(setf  Edges  'nil) 

(setf  Facets  'nil) 

(setf  Arithmetic-center  'nil) 

(setf  Connected-to  'nil)) 

(defmethod  (volume  : find-arithmetie-center )  () 

;  find  the  average  of  all  the 

vertices 

;  of  the  volume .  do  not  change  values 
;  in  the  volume 

(let  ((temp-sum  (send  (eval  (first  Points))  : list-format ) ) 

(nr-points  (length  Points))) 

(loop  for  P  in  (rest  Points) 

do  (setf  temp-sum  (map  'list  '+  temp-sum 

(send  (eval  P)  : list-format) )) ) 

(init-point  (map  ' list  ' /  temp-sum 

(make-list  3  : initial-element  nr-points))))) 


(defmethod  (volume  :make-node-list)  () 

;  make  a  list  of  absolute  point  coords  in 

graphic 

(loop  for  P  in  points  ;  format  (eg  4  element  list) 

;  used  in  GRAPHICS, 
collect  (reverse  (append  (list  '1) 

(reverse  (send  (eval  P)  : list-format ))))) ) 


(defmethod  (volume  :make-polygon-list)  () 

; index  point  values  to  points  in  node 

list 

(loop  for  L  in  edges  ;  used  in  GRAPHICS 

do  (setf  Ptl  (car  (send  (eval  L)  :endpoint-list) ) ) 
do  (setf  Pt2  (cadr  (send  (eval  L)  :endpoint-list) ) ) 

collect  (list  (position-if  '(lambda  (A)  (equal  A  Ptl))  node-list) 
(position-if  '(lambda  (A)  (equal  A  Pt2))  node-list)))) 

(defmethod  (volume  :print)  () 

(pprint  (list  Visibility  Probability-of-detection  Composition  Points  Edges 

Facets 

arithmetic-center  connected-to)  *output-strerm*) ) 
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■UNIVERSE 


(defflavor  Universe 
(Volumes 
Observers 
universe 

static-vectors 
static- vector -counter 
static-lines 
static-lines-counter 
static-points 
static-points-counter) 

0 

: get tab le- instance -var iablea 
: settable-instance -var iables 
: inittable-instance-variables 
: out side-acces sible-in stance -variables) 

(defmethod  (universe  : save-static-items)  ()  ;  save  state  of  static 

universe 

(setf  static-vectors  ‘list-of-vectors*) 

(setf  ‘minimum-vectors-counter*  *vectors-counter‘) 

(setf  static-lines  ‘list-of-lines*) 

(setf  *minimum-lines-counter *  *lines-counter‘) 

(setf  static-points  *list-of-points‘) 

(setf  *minimum-points-counter*  ‘points-counter*) 

(setf  ‘minimum-planes-counter*  ‘planes-counter ‘ ) 

(setf  *minimum-facets-counter‘  ‘facets-counter*) 

(setf  ‘minimum-voluines-counter*  * volumes -counter * ) ) 


;  space  of  all  volumes 

observers  located  within  the  defined 

save  the  state  of  the  lines,  points  and 
vectors  used  to  build  the  static  visibility 
model 


************************************************************************** 

t  i 

; ;  FUNCTIONS  TO  INITIALIZE;  GET  NAMES  OF  OBJECTS  AND  MAKE  NAMES  GLOBAL 
/  * 

o**************************************************-*********************** 


(defun  make-origin  ()  ;  names  of  special  points 

and 

(gensym  (incf  *points-counter* ) )  ;  other  unique  flavors, 

(setf  *origin*  (make-instance  'point 

:x-coord  '0 
:y-coord  '0 
: z-coord  '  0) ) 

(pushnew  '‘origin*  *list-of-points*)  ) 


(defun  make-null-vector  () 

(gensym  (incf  *vectors-counter*) ) 

(setf  ‘null-vector*  (make-instance  'vector 

:i  '0 

s  j  '0 

: k  '0 

:Start-point  '‘origin* 
:End-point  '‘origin*)) 
(push  ' ‘null-vector ‘  »list-of-vectors* ) ) 
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(defun  m&k«-point-nuM  <)  ; produce  variable  names  "on  the  fly” 

(oond  ((>  *pointa-counter*  (1-  *max-counter-value*) ) 

(setf  *points-counter*  *minimum-points-counter*) ) ) 

(gensym  (incf  *points-counter*) ) 

(intern  (ganaym  "point"))) 

(da fun  make- line -name  () 

(cond  ((>  * lines -counter*  (1-  *max-counter-value*) ) 

(aetf  * lines -counter*  *minimum-linea-counter*) ) ) 

(gensym  (incf  *linea-oounter*) ) 

(intern  (gensym  "line"))) 

(defun  make-vector-name  () 

(cond  ( (>  *vectora-counter*  (1-  *max-oounter-value*) ) 

(aetf  *vectors-counter*  *minimum-veotore-counter*) ) ) 

(gensym  (incf  *vectors-counter*) ) 

(intern  (gensym  "vector"))) 

(defun  make- facet- name  () 

(cond  ((>  *facete-counter*  (1-  *max-counter-value*) ) 

(aetf  *faceta-counter *  "minimum-facet a-counter*) ) ) 

(gensym  (incf  *facets-counter*) ) 

(intern  (gensym  "facet") ) ) 

(defun  make-plane-name  () 

(cond  ( (>  *planes-counter*  (1-  *max-counter-value*) ) 

(setf  *planes-counter*  *minimum-planes-counter*) ) ) 

(gensym  (incf  *planes-counter*) ) 

(intern  (gensym  "plane"))) 

(defun  make-volume-name  () 

(cond  ( (>  *volumes-counter*  (1-  *max-counter-value*) ) 

(setf  *volumes-counter*  *minimum-volumes-counter*) ) ) 

(gensym  (incf  *volumes-counter*) ) 

(intern  (gensym  "volume"))) 

*«*******«*********«*»*«»***»»**•*»********»»******************»*»**»*•** 

t  i 

;;  FLAVOR  INSTANTIATION  FUNCTIONS 

;;  Note:  all  of  therse  functions  will  stop  keeping  lists  of  previously 
; ;  created  instantiations  after  flag 

;;  *done-making-new-viaibility-volumes-f lag*  is  set  to  T 

ft************************************************************************ 


; - MAKE  A  POINT - 

(defun  init-point  (List-of-values)  ;  see  if  point  already  exists 
(nonrecursive) 

(cond  ((and  (not  (null  *list-of-points*) ) 

(no'  done-making-new-viaibility-volumes-flag* ) ) 

(loop  fc-  P  in  *liat-of-pointa* 
do  (cond  ((apply  'and 

(map  'list  ♦' equal-error 

(map  'list  'rationalize  list-of-values) 
(send  (aval  P)  : list-format) ) * 
(return-from  init-point  P)))))) 

(init-new-point  list-of-values) ) 
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(defun  init-new-point  (List-of-values) 

(let  < (temp  (make-point-name) ) ) 

(set  temp  (make- instance  point 

:x-coord  (rationalize  (first  List-of-values) ) 
:y-coord  (rationalize  (second  List-of-values) ) 
:z-coord  (rationalize  (third  List-of-values)))) 
(push  temp  *list-of-points*) 
temp) ) 

1 - make  a  vector - 


(defun  init-veotor  (Start-point  End-point)  ;  check  to  see  if  vector  already 
built 

(cond  ((not  *done-making-new-visibility-volumes-flag*) 

(loop  for  V  in  *list-of-vectora* 

do  (cond  ((equal  (send  (aval  V)  : endpoints) 

(list  Start-point  End-point) ) 

(return-from  init-vector  V)))))) 

(init-new-vector  Start-point  End-point) ) 

(defun  init-nev- vector  (Sp  Ep) 

(let  ( (temp  (make-vector-name) ) ) 

(set  temp 

(make-instance  ' vector 

:i  (-  (point-x-coord  (eval  Ep) )  (point-x-coord  (eval  Sp) ) ) 

:j  (-  (point-y-coord  (eval  Ep) )  (point-y-coord  (eval  Sp) ) ) 

:k  (-  (point-z-coord  (eval  Ep) )  (point-z-coord  (eval  Sp) ) ) 

: Start-point  Sp 
: End-point  Ep) ) 

(push  temp  *list-of-vectora* ) 
temp) ) 


- - MAKE  A  LINE  SEGMENT - 

(defun  init-line  (Position-vector  Direct ion- vector) 

;  valid  construction  for  a  line??? 

(cond  ((and  (equal  (vector-Start-point  (eval  Position-vector))  '‘origin*) 
(member-p  ( vector-end -point  (eval  Position-vector)) 

(send  (eval  Direction-vector)  [endpoints))) 
(Find-or-make-line  Position-vector  Direction-vector)) 

(t  (terpri) 

(princ  "Error  invalid  vectors:  ") 

(prinl  (list  position-vector  direction-vector))  (terpri)))) 

(defun  Find-or-make-line  (Pv  Dv)  ;  check  to  see  if  line  already 

built 

(cond  ( (not  *done-making-new-visibility-volumes-flag*) 

(loop  for  L  in  *list-of-lines* 

do  (cond  ( (and  (member-p  (vector-end-point  (eval  Pv) ) 

(send  (eval  (old-line-Dv  L)  )  .-endpoints)) 

(or  (equal  (send  (eval  Dv)  [endpoints) 

(send  (eval  (old-line-Dv  L) )  [endpoints)) 

(equal  (send  (eval  D V;  [endpoints) 

(nreverse 

(send  (eval  (old-line-Dv  L) )  [endpoints))))) 
(return-from  find-or-make-line  L) ) ) ) ) ) 

(init-new-line  Pv  Dv) ) 
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(defun  init-new-line  (Pv  Dv) 

(let  ( (temp  (make-line-name) ) ) 

(set  temp  (make-instance  ' line-segment 
: t-max  '1 

:Position-vector  Pv 
: Direction-vector  Dv 
: characteristics  'nil)) 
(push  temp  *list-of-lines*) 
temp) ) 

(defun  old-line-Dv  (Line) 

(line-segment-Direction-vector  (aval  Line) ) ) 


-MAKE  A  PLANE 


(defun  init-plane  (List-of-values)  ;  see  if  plane  already  exists 
(nonrecursive) 

(cond  ((and  (not  (null  *liet-of-planes*) ) 

(not  *done-making-new-visibility-volumes-flag*) ) 

(loop  for  P  in  *list-of-planes* 

do  (cond  ((or  (equal  (send  (aval  P)  :list-coeff) 
list-of-values) 

(apply  'and  (map  'list  ('equal-error 

(send  (aval  P)  :list-coeff) 
list-of-values) ) ) 

(return-from  init-plane  P) ) ) ) ) ) 

(init-new-plane  list-of-values) ) 

(defun  init-new-plane  (List-of-values) 

(let  ((temp  (make-plane-name))) 

(set  temp  (make-instance  'plane 

:a-coef  (rationalize  (first  list-of-values) ) 
:b-coef  (rationalize  (second  list-of-values)) 
:c-coef  (rationalize  (third  list-of-values)) 
:Ao  (fourth  list-of-values))) 

(push  temp  *list-of-planes*) 
temp) ) 


- make  ALL  FACETS - 

Used  by  intercept  routines  to  rebuild  volume  facets 

***  WARNING  *** 

Note:  Facets  MUST  be  convex  and  MUST  NOT  be  adjacent  to 

facets  in  the  same  volume  with  the  same  plane  equation 


;  Used  by  input  method  1  and  by  all  intercept  routines 

(defun  make-all-facets  (Volume) 

(reset -point -property- lists  Volume) 

;  initialize  point  'lines  property  list 
(loop  for  L  in  (Volume-edges  (eval  Volume) ) 

do  (let*  ((endpoints  (send  (eval  L)  sendpoints) ) 

(first-point  (first  endpoints)) 

(second-point  (second  endpoints))) 

(aetf  (get  first-point  'lines)  (adjoin  L  (get  first-point  'lines))) 
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(setf  (gat  second-point  ' lines)  (adjoin  L  (get  second-point  ' lines) ) ) ) ) 

;  build  all  facets  from  points 

(loop  for  P  in  (volume-points  (eval  Volume))  ;  make  all  facets  possible 
do  (loop  for  L  in  (get  P  'lines) 

do  (let*  ((other-end-L  (send  (eval  L)  :other-end  P) ) ) 

(initialize-search  Volume  P  (list  L)  (List  other-end-L  P))))) 


(reset -point -property-lists  Volume)) 


(defun  initialize-search  (Volume  Goal  old-lines  old-points) 

(let  ( (point2  (first  old-points) ) 

(Line  (first  old-lines) ) 

(search-result  'nil) 

(facet-name  'nil)) 

(loop  for  L  in  (get  point2  ' lines) 
do  (cond  ( (and  (not  (equal  L  Line) ) 

(not  (equal  Goal  (-end  (eval  L)  s other-end  point2)))) 

(let  ((plane  (init-plane  (make-a-normalized-plane  L  Line)))) 

(cond  ((not  (member-p  plane  (get  Goal  'planes))) 

(setf  (get  Goal  'planes)  (adjoin  plane  (get  Goal  'planes))) 
(setf  search-result  (search-to-make-facet  Goal 
plane 

(list  L  Line) 

(pushnew  (send  (eval  L)  : other-end  point2) 
old-points) 


Volume) ) ) ) 


'nil 
'nil) ) 

(cond  (  (<*■  '3  (length  (first  search-result))) 

(setf  facet-name  (init-f acet-2  search-result))) 
(t  (setf  facet-name  'nil))) 

(cond  ( (not  (null  facet-name) ) 

(setf  (volume-facets  (eval  Volume) ) 

(adjoin  facet-name  (volume-facets  (eval 


)))))))))) 


(defun  search-to-make-facet  (Goal  ; 

Facet -plane  ; 

old-lines  ; 

old-points  ; 

rejected-points  ; 
rejected-lines)  ; 

(let  ((current-point  (first  old-points)) 

(last-line  (first  old-lines)  ) 

(Line  'nil) 

(possible-paths  'nil)) 

(loop  for  candidate-line  in  (get  current-point  'lines) 
do  (let  ( (other-end-cand-line 

(send  (eval  candidate-line)  :other-end  current-point))) 

(cond  ((apply  'and  (list  (not  (member-p  candidate-line  old-lines)) 
(not  (member-p  candidate-line  rejected-lines) ) 
(not  (member-p  other-end-cand-line 
rejected-points) ) ) ) 

(cond  ((not  (member-p  other-end-cand-line  old-points)) 

(cond  ((send  (eval  facet-plane)  :test-equal 
(make-a-plane  other-end-cand-line 
(first  old-lires))) 

(setf  (get  other-end-cand-line  'distance) 

(distance  Goal  other-end-cand-line)) 

(setf  possible-paths 

(adjoin  candidate-line  possible-paths))) 

(t  (pushnew  candidate-line  rejected-lines)))) 
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((equal  other-end-cand-line  Goal) 

(loop  for  P  in  (adjoin  other-end-cand-line  old-points) 
do  (setf  (get  P  'planes) 

(adjoin  Facet-plane  (get  P  'planes)))) 

(return-from  search-to-make-facet  (list 

(adjoin  candidate-line 
old-lines) 
facet -plane) ) ) 

(t  (pushnew  candidate-line  rejected-lines)))) 

(t  (pushnew  candidate-line  rejected-lines))))) 

(cond  ((not  (null  possible-paths)) 

(setf  Line  (minimum-distance  possible-paths  current -point) ) 

(push  Line  old-lines) 

(pushnew  (send  (eval  Line)  :other-end  current -point)  old-points)) 

(t  (pushnew  last-line  rejected-lines)  ;  remove  last  line,  current 

point 

(pushnew  current-point  rejected-points)  ;  and  retrace  steps  (backtrack) 
(setf  old-lines  (rest  old-lines)) 

(setf  old-points  (rest  old-points)) 

(cond  ((>2  (length  old-lines))  s  backtracked  too  far? 

(return-from  search-to-make-facet  'nil))))) 

(search-to-make-facet  Goal  Facet-plane  old-lines  old-points 

rejected-points  rejected-lines) ) ) 


(defun  init-facet-2  (properties)  ;  Check  to  see  if  already  built  facet 

(cond  ((not  (null  properties))  ;  else  return  name  of  new  facet,  or  nil. 

(let*  ((edges  (first  properties)) 

(plane  (second  properties) ) 

(test-plane  (map  ' list  ' aba 

(map  'list  '*  (send  (eval  plane)  :list-coeff) 
‘one-veotor*) ) ) 


(equal-flag  't)) 

(cond  ( (equal-p  teat-plane  *zero-vector*)  ;  remove  artifact  facets 
(return-from  init-£acet-2  'nil))) 

(cond  ( (not  (null  *list-of-facets*) ) 

(loop  for  F  in  *list-of-f acets *  ;  see  if  already  exists 

do  (cond  ((equal  (length  edges) 

(length  (facet-edges  (eval  F) ) ) ) 

(setf  equal-flag  't) 

(loop  for  E  in  edges 

do  (cond  ((not  (member-p  E  (face  -edges  (eval  F) ) ) ) 
(setf  equal-flag  'nil)))) 

(cond  (equal-flag 

(return-from  init-facet-2  F) )))))) ) 
(make-new-facet  edges  plane) ) ) 

(t  (return-from  init-facet-2  'nil)))) 


(defun  make-new-facet  (list-of-edges  plane) 

(let  ((plane-equation  (send  (eval  Plane)  : list-coeff ) ) 
(temp  (make-facet-name))) 

(set  temp  (make-instance  ' facet 

:Edges  list-of-edges 
: center  'nil 
: connects  'nil 

:a-coef  (first  Plane-equation) 
:b-coef  (second  Plane-equation) 
:c-coef  'third  Plane-equation) 

:Ao  (fourth  Plane-equation))) 

(push  temp  *list-of-facets* ) 
temp) ) 
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- - MAKE  A  FACET  FROM  INPUT 

;  Used  by  input  method  2  (only) 


(defun  make-a-facet  (points)  ;  build  a  facet  from  a  list  of  point  names 
(let  ((first-point  (first  points)) 

(start-point  (first  points) ) 

(lines  'nil) 

(plane-of-facet  'nil)) 

(loop  for  End-point  in  (rest  points)  ;  construct  edges  of  faaet 
do  (let  () 

(setf  lines  (adjoin  (make-line  Start-point  End-point)  lines)) 

(setf  Start -point  End-point))) 

(setf  lines  (adjoin  (make-line  Start-point  First-point)  lines)) 

(setf  Plane-of-facet  (init-plane  (make-a-normalized-plane  (first  lines) 

(second  lines)))) 

(make-new- facet  lines  plane-of-facet)))  ;  return  new  facet  name 


(defun  build-side-facet  (Ptl  Pt2  Side-points)  ;  make  a  facet  w/disjoint  list  of 
points 

(make-a-facet  (append  (list  Ptl  Pt2)  Side-points))) 

(defun  build-terrain  (data)  ;  build  facets  with  raw  facet  data,  where  data 

;  is  in  format  (point  point  point  . . . ) 

;  and  the  points  are  in  format  (x  y  z) 

;  return  a  list  of  all  facets  built 

(let  ( (list-of-facets  'nil)) 

(loop  for  Facets  in  Data  ;  each  list  within  data  is  a  facet 
do  (let  ((points  (map  'list  #' init -point  Facets))) 

(setf  list-of-facets  (adjoin  (make-a-facet  points)  list-of-facets)))) 
list-of-facets) ) 


•MAKE  A  VOLUME 


(defun  init-volume  (data) 

(let  ((temp  (make-volume-name ) ) 

(volume-data  (pop  data) ) ) 

(set  temp  (make-instance  'volume 

:Visibility  (second  volume-data) 
:Probability-of-detection  'nil 
: Composition  (first  volume-data) 
iPoints  ' ( ) 

: Edges  ' ( ) 

: Facets  ' () 

: arithmetic-center  'nil 
: connected-to  'nil)) 

(push  temp  *list-of-volumes* ) 

(Initialize- volume  temp  data) 

temp) )  ;  return  name  of  volume  created 
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******************************************************************************* 


CONSTRUCTION  UTILITY  FUNCTIONS 


(defun  aample-2-1  () 

(aet-up  1  ’ ”t27-ridgea-ahadown) 

(init-obaarver  ' (500  50  200)  '0.02) 

(aat-up-2) 

(pprint  (langth  (univerae-volumea  *univerae*) ) ) 

(a-atar-aa»roh  (init-point  '<0  0  200))  (init -point  '(0  1000  200))  'nil  'nil)) 

(dafun  aample-4-2  () 

(aat-up  2  ' "t310-full-ridge") 

(init-obaarver  '(10  500  250)  '0.75) 

(init-obaarver  ' (990  500  250)  '0.50) 

(aet-up-2) 

(pprint  (length  (univerae-volumea  *univerae*) ) ) 

(a-atar-search  (init-point  '(500  10  400))  (init-point  '(500  990  400))  'nil 
'nil)) 

(defun  aample-5-1  ()  ;  one  oba  in  central  valley 

(aet-up  1  ' ”t25-ridge-box" ) 

(init-obaerver  ' (0  500  200)  '0.02) 

(aet-up-2) 

(pprint  (length  (univerae-volumea  *univerae* ) ) ) 

(a-atar-aearch  (init-point  '(10  10  500))  (init-point  '(10  990  225))  'nil 
'nil)) 

(defun  aample-5-2  ()  ;  one  oba  in  central  valley,  one  on  aide 

(aet-up  1  ' "t25-ridge-box") 

(init-obaerver  ' (0  500  200)  '0.75) 

(init-obaerver  ' (50  50  250)  '0.75) 

(aet-up-2) 

(pprint  (length  (univerae-volumea  ‘universe*) ) ) 

(a-atar-aearch-m  (init-point  '(10  10  500))  (init-point  '(10  990  225))  'nil  '10 
'nil)) 

(defun  aample-6-1  ()  ;  aingle  obaerver  on  one  aide  of  central 

valley 

(aet-up  2  '  "t320-double-peak") 

(init-obaerver  '(10  500  225)  '0.02) 

(aet-up-2) 

(pprint  (length  (univerae-volumea  *univerae*) ) ) 

(a-atar-aearch  (init-point  '(500  10  250))  (init-point  '(500  990  250))  'nil 
'nil)  ) 

(defun  aample-6-2  ()  ;  one  each  on  each  aide  of  the  peaka 

(aet-up  2  ' "t320-double-peak") 

(init-obaerver  ' (10  250  250)  '0.75) 

(init-obaerver  '(990  750  250)  '0.75) 

(aet-up-2) 

(pprint  (length  (univerae-volumea  *univerae*) ) ) 

(a-atar-aearch  (init-point  '(500  10  250))  (init-point  ’(500  990  250))  'nil 
'nil)) 
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(defun  sample-7-1  () 

(set-up  2  ' "t360-2-peak-2-ridge") 

(init-observer  ' (100  800  250)  '0.75) 

(set -up-2) 

(pprint  (length  (universe-volumes  'universe*) ) ) 

(a-star-search  (init -point  '(10  10  300))  (init-point  '(990  990  300))  'nil 
'nil)) 

(defun  sample-8- 1  () 

(set-up  2  ' "t350-six-peaks") 

(init-observer  '(100  BOO  250)  '0.75) 

(set -up-2) 

(pprint  (length  (universe-volumes  'universe*))) 

(a-star-search  (init-point  '(10  10  300))  (init-point  '(500  990  300))  'nil 
'nil)) 

(defun  sample-final-paths  () 

(let  ((goal  (init-point  '(10  990  225))) 

(list-of-start -points  'nil)) 

(loop  for  C  from  10  upto  990  by  100 
do  (setf  list-of-start-points  (adjoin  (init-point  (list  C  '10  '600)) 

list-of-start-points) ) ) 

(loop  for  S  in  (reverse  list-of-start-points) 
do  (speed-demon) 

do  (a-star-search  S  Goal  'nil' nil)) 

(display-paths  *list-of-paths*) ) ) 

(defun  sample-9-1  ()  ;  one  obs  in  central  valley 

(set-up  1  ' "t21-ridge-Y") 

(init-observer  ' (990  500  200)  '0.0150) 

(set-up-2) 

(pprint  (length  (universe-volumes  'universe'))) 

(a-star-search  (init-point  '(10  10  410!)  (init-point  '(10  990  410))  'nil 
'nil)) 
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...  Mode : Common-Lisp;  Base: 10  -*- 

(defvar  testvar) 

(defun  TS  () 

(a -star-search  (init-point  '(0  0  200))  (init-point  '(0  1000  200))  'nil  't)) 
(defun  TS1  () 

(a-star-search  (init-point  '(00  200))  (init-point  ' (0  1000  200))  't  'nil)) 


(defun  TS2  ( ) 

(a-atar-aearch-M  (init-point  ' (0  0  200))  (init-point  ' (0  1000  200))  't  5 
'nil)) 


(defun  TS3  () 

(a-atar-aearch-M  (init-point  '(0  0  200))  (init-point  '(0  1000  200))  'nil  10 
'nil)) 

(defun  T S4  () 

(a-atar-aearch-M  (init-point  ' (0  0  200))  (init-point  ' (0  1000  200))  'nil  5 
'  t) ) 

(defun  TS5  ()  ;uaed  with  box-canyon  or  t-27-ridge-shadow 

(a-atar-aearch-M  (init-point  ' (510  0  900))  (init-point  ' (500  1000  900))  'nil  5 
't)) 

(defun  TS6  ()  ;uaed  with  box-canyon 

(aetf  teatvar  (a-atar-aearch-M  (init-point  ' (900  0  300))  (init-point  ' (990 
1000  250) )  'nil  5  ' t) ) ) 

(defun  TS7  ()  /used  with  or  t-27-ridge-shadow 

(aetf  testvar (a-atar-aearch-M  (init-point  '(0  310  210))  (init-point  '(1000  750 
300) )  'nil  5  ' t ) ) ) 

(defun  TS8  ()  /used  with  or  t-27-ridge-shadow 

(a-atar-aearch-M  (init-point  ' (10  0  300))  (init-point  '(990  990  990))  'nil  5 
't)) 

(defun  TS9  ()  /used  with  or  t-27-ridge-ahadow 

(a-star-aearch-M  (init-point  ' (900  10  910))  (init-point  ' (1000  750  300))  'nil 
5  't)) 

(defun  TS340-1  () 

(a-atar-aearch  (init-point  ' (950  0  210))  (init-point  ' (990  1000  550))  'nil 
'nil)) 

(defun  ta-apeed  (path-list) 

(let  ( (timel) 

(time2) ) 

(aetf  timel  (time) ) 

(random- ray- optimize  path-list) 

(aetf  time2  (time) ) 

(princ  "this  is  timel  -  ") (princ  timel ) (terpri) 

(princ  "this  is  time2  -  "((princ  time2 ) (terpri) 

(princ  "the  difference  is  -  ") (princ  (-  time2  timel) ) (terpri) ) ) 


(defun  ts-speed-old-opt  (path  number-of-optimizations) 
(let  ((timel) 
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(time 2) ) 

(setf  timel  (time) ) 

(do*  ( (new-path  (optimixe-path  path)  (optimixe-path  new-path) ) 
(count  (*  number -of-optimi rations  1) (-  count  1))) 

( (zarop  count)  (princ  path) (path-data  naw-path))) 

(satf  time2  (time) ) 

(princ  "this  is  timal  -  ") (princ  timal) (tarpri) 

(princ  "this  is  tima2  -  ") (princ  tima2) (tarpri) 

(princ  "tha  diffaranca  is  -  ") (princ  <-  tima2  timal) ) (tarpri) ) ) 


(defun  TS25-1  () 

(satf  tastvar  (a-atar-saarah-m  (init-point  '  (950  0  510) ) 

(init-point  '(990  1000  550)) 

'nil 

5 

't)) 

) 


(defun  TS10  () 

(setf  testvar 

(a-star-aearch-m  (init-point  '(10  400  910))  (init-point  '(110  990  450))  'nil 
5  'nil))) 

(defun  TS11  ()  ;used  with  or  t-27-ridge-shadow 

(setf  testvar (a-star-aearch-M  (init-point  '(0  0  990))  (init-point  '(1000  750 
300) )  'nil  5  't) ) ) 

(defun  TS12  ()  ;used  with  t-27  for  user  adjustment 

(a-atar-search-M  (init-point  ' (410  10  900))  (init-point  '(900  990  300))  'nil  5 
’t)) 

(defun  user-adj  (point) 

(let*  ((PI  (init-point  point)) 

(line  (make-line  (init-point  '(410  10  900))  PI) > 

(path  (revise-path  '|path0006|  line))) 

(path-data  '|path0006|) 

(princ  path) 

(path-data  path) 

(path-for-iris  path) ) ) 

(defun  TS13  ()  ; used  with  t-27  for  user  adjustment 

(a-star-search-M  (init-point  '(300  10  450))  (init-point  '(990  900  250))  'nil  5 
't)) 


(defun  TS14  () 

(a-star-search  (init-point  ' (500  200  600))  (init-point  ' (300  990  440))  'nil 
'nil)) 
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APPENDIX  B 


This  Appendix  contains  a  listing  of  the  following  files: 
ppgh.c 
rotate.h 
lightdef.c 
lightdef.h 
Makefile 


Instructions  for  use  of  graphics  program: 

1.  Load  all  the  above  files  along  with  basel.dat,  groundl.dat,  and  pathl.dat  in 
one  directory  on  the  graphic  workstations. 

2.  Type  make< cr>. 

3.  Type  ppgh<cr>. 

4.  Open  the  window  with  the  mouse  and  observe  the  paths  and  terrain. 

5.  To  exit  click  on  the  right  mouse  button  and  select  "exit". 
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/*  this  is  sn  IRIS-4D  Program  */ 

/*  this  is  fiX*  ppgh.c  short  for  path  planning  graphics 

This  program  is  us*d  in  conjunction  with  data  fil*a  cr*at*d 
by  a  LISP  Optimal  Path  Planning  Program 

It  is  an  alteration  of  program  rotat*2.c  with  z-bu£f*ring  and  rgbmod* 
with  polygon  removal  and  lighting  routines... 


*/ 


(include 

(include 

(include 

(include 

(include 

(include 


"gl.h" 
"device. h" 
"math.h" 
"rotate. h" 
"stdio.h" 
"lightdefs.h" 


/*  get  the  material/light/lighting  model  defs  */ 


(define 

(define 

(define 

(define 

(define 

(define 

(define 

(define 

(define 

(define 

(define 

♦define 

(define 

(define 

(define 

(define 


NEARDEPTH  0x00000 

FARDEPTH 

0x7ffff 

NEARCLIPPING  10.0 

FARCLIPPING  6000.0 

CUBEX 

500.0  /* 

COBEY 

300.0  /* 

COBEZ 

•500.0  /* 

CUBESIZE 

100.0 

VIEWX 

500.0  /* 

VIEWY 

500.0 

VIEWZ 

2000.0 

REFX 

COBEX  /* 

REFY 

CUBEY 

REFZ 

COBEZ 

PI  3.1416 

MAXPOINTS 

;  5 

/*  presently  set  for  the  4D/GT  */ 


/*  near  clipping  plan*  is  at  -10.0  */ 
/*  far  clipping  plane  is  at  -6000.0  */ 

location  of  the  cube  */ 
actually  the  center  */ 
of  our  terrain  model  */ 


initial  location  of  the  viewpoint  */ 


reference  point  we  are  looking  towards 


*/ 


float  viewx  ■  500.0;  /*  location  of  the  viewpoint  */ 

float  viewy  -  300.0; 
float  viewz  “  1000.0; 
float  vail; 

float  viewingdistance  «  1500.0;  /*  initial  distance  from  center  of  obj  */ 
float  viewingangle  -  0.0;  /*  angle  in  YZ  plane  at  which  obj  is  viewed  */ 


int  radius, vaiO; 
int  sens  -  10; 


typedef  struct  threedobj  { 
int  numpta ; 

float  point (MAXPOINTS] [3] ; 
float  normal [3] 

); 

struct  threedobj  bas*[20J,  ground(100]; 
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int  numbasepts ,  numgroundpts; 


int  nunberof paths;  /*  this  is  tha  number  of  paths  in  tha  fila  max  is  10  */ 
int  numberof waypoints [10] ;  /*  thia  is  tha  max  num  of  waypoints  for  the 

fltpath*/ 

float  waypoints[10] [100] [4] ;  /‘array  for  storing  tha  fit  path*/ 
long  xwinsize,  ywinsiza  ; 


main  () 

< 


/*  popup  menu's  name  */ 
int  mainmenu; 

int  thread,  twod,  help;  /*  window  numbers  */ 
int  hititem;  /*  variable  holding  hit  name  */ 

short  val,  valsave;  /*  value  returned  from  the  event  queue  */ 
char  filename [20 J ; 
int  i, j; 


/*  initialize  the  IRIS  system  */ 
initialize ((thread,  stwod) ; 

/*  initialize  the  material  definitions  */ 
initializematerials () ; 

/*  initialize  the  light  definitions  */ 
initializelights ( ) ; 

/*  initialize  the  lighting  model  */ 
initializelmodel () ; 

/*  reset  dials  */ 
setdialO ( ) ; 
setdiall ( ) ; 
setdial2 ( ) ; 

/*  make  the  popup  menus  */ 
mainmenu  ■=  makethemenus  ()  ; 

/*  set  all  the  accumulative  matrices  to  unit  matrices  */ 
resetallaccumulativematrices ( ) ; 

/*  go  get  the  polygons  that  make  up  the  base  */ 
at rcpy (filename,  "basel.dat"); 
inputstructure (base,  Snumbasepts,  filename); 


/*  compute  the  normals  for  tha  base  */ 
calculatenormal (base, numbasepts,  500. 0,  0.0,  -500.0); 
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tifdef  TRACE 

/*  print  out  th*  input  */ 
for  (i«0;  i<numbaa*pta;  i++) 

( 

printf ("number  of  point*  -%d\n", baa* [i] .nurapta) ; 
printf ("normal  for  %d  ia  %lf  %lf  %lf  \n", i,baa*(i) .normal(O) , 
base(i] .normal [1] , 
baa*(i] .normal[2] ) ; 


for  (j“0;  j<baa*  [i]  .nunpts;  j++) 

< 

printf ("point* l %d] (0]-%.f  pointa[%d] (lj-*.f  pointa[%d] J2]-%.f\n", 
j, baa* (i J  .point ( j]  (0], 
j,ba**(i] .pointl j] [1], 
j, baa* (i J .pointl j] (2]); 

) 

) 

♦•ndif 

/*  input  th*  ground  data  */ 
atrcpy (f ilename,  "groundl.dat"); 

inputatructure (ground,  Snumgroundpta,  filename); 
calculatenormal (ground, numgr oundpt a ,  S00.0,  -5000.0,  -500.0); 

tifdef  TRACE 

for  (i«0;  Knumgroundpts;  i++) 

< 

printf ("number  of  point*  -%d\n", ground (i) . numpta) ; 
printf ("normal  for  %d  ia  %lf  %lf  %lf  \n",i, 
ground [i] .normal [0] , 
ground [ i] .normal [ 1]  , 
ground(i] .normal [2] ) ; 


for  (j=0;  j<ground[i]  .numpts;  j++) 

<  ' 

printf ("point* [%d] [0]-%.f  pointa[%d) t 1) — % . f  pointa[%d] [2]-%.f\n", 
j, groundji) .pointl j] (0] , 
j, ground [i] .pointl j] [1], 
j , ground ( i J . point ( j ] ( 2 ] ) ; 


) 

♦•ndif 

/*  get  the  input  for  the  flight  path  */ 
input  1 inearray () ; 
tifdef  TRACE 

printf ("thia  ia  the  Bet  input  from  the  file\n"); 
for(i«0;  i<numberof waypoint* ;  i++) 

( 

printf ("i«  %d  x»  %f  y»  %f  z«  %f  p*rc*ntdetection-  %f\n”, 
i, waypoint* [i] [0] , waypoint* [i] [1], 
waypoint a (ij (2] ,  waypoints (i J (3] ) ; 

> 

tendif 
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while (TRUE) 

< 


/*  do  we  have  something  on  the  event  queue  ?*/ 
if  (qteat  () ) 

( 

switch ( qread ( t val ) ) 

{ 


case  MEMUBUTTON: 

if (val  —  1) 

( 

/*  we  must  be  in  MSINGLE  mode  to  do  popup  menus! ! !  */ 
■mode  (MS INGLE)  ; 

/*  which  popup  selection  do  we  want?  */ 
hititem  -  dopup (mainmenu) ; 

/*  put  us  back  into  MVIBWING  mode  */ 

■mode (MVIEWING) ; 

/*  do  something  with  the  popup  hit  */ 
processmenuhit (hititem) ; 


) 

break; 


case  DIALO; 


valO  «  (int) ((val  /  sens)); 
if  (valsave  <  val) 

ry  -  valO  *  YROTAMOUNT; 

if  (valsave  >  val) 

ry  =  valO  *  YROTAMOUNT; 


buildmovingviewingmatrix (viewx, viewy, viewz, REFX, REFY, REFZ) ; 

ry  -  0; 
setdialO ( ) ; 

/*  valsave  ■«  val;*/ 

break; 

case  DIAL1: 

viewingangle  -  val/sens; 

viewy  -  (float) sin ( (double) (viewingangle  *  PI  /  180.0))* 
viewingdistance  +  REFY; 

viewz  -  ( float) cos ( (double) (viewingangle  *  PI  /  180.0))* 
viewingdistance  +  REFZ; 

break; 
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case  DIAL2: 


viewingdistance  -  (float)val  *  10; 

viewy  p  (float) sin ( (double) (viewingangle  *  PI  /  180.0))* 
viewingdist ance  +  REFY; 

viewz  -  (float) cos ( (double) (viewingangle  *  PI  /  180.0))* 
viewingdistance  +  REFZ; 
tif def  TRACE 

printfC'val  is  %d  viewingdist  is  %f  viewy  is  %f  viewz  is  %f\n\n", 
val, viewingdistance, viewy,  viewz) ; 

fendif 


break; 


case  REDRAW: 

reshapeviewport () ; 
break; 
default : 
break; 

)  /*  end  switch  on  event  queue  item  */ 

)  /*  endif  qtest()  */ 


/*  draw  the  background  color  */ 

RGBcolor (150, 150, 150) ;  /*  grey  */ 
clear ( ) ; 

/*  turn  on  Z-buffering  */ 
zbuffer (TRUE) ; 

/*  clear  the  z-buffer  */ 
zclear  ()  ; 

/*  put  up  the  non-moving  viewing  matrix  for  the  meter  */ 
buildnonmovingviewingmatrix (VIEWX, VIEWY, VIEWZ, REFX, REFY, REFZ) ; 

/*  display  the  number  of  frames  per  second 

(0.0,40.0,-20.0)  is  the  loc  of  the  meter  in  world  coords. 
15.0  is  the  radius  to  use  for  the  meter. 

40.0  is  maximum  frames  per  second. 

Note:  this  measures  actual  CPU  time  used  by  your 
process  and  other  users  on  the  system  will 
make  the  output  meter  view  strange. 

*/ 

zbuffer (FALSE) ; 

lmbind (LMODEL,  0)  ;  /*  turn  off  lighting  model  */ 

zbuffer (TRUE) ; 

lmbind (LMODEL, MYMODEL) ;  /*  turn  my  lighting  back  on  */ 
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/*  put  up  the  moving  viewing  matrix. 

The  input  arguments  are  the  center  point  for  the  object 
we  want  to  move  and  the  reference  point  in  the  scene. 

Me  need  this  guy  so  we  can  always  rotate  around 
the  screen  frame  of  reference. 

*/ 

buildmovingviewingmatrix (viewx, viewy,  view* ,  REFX,  REFY,  REFZ) ; 

/*  draw  the  base  */ 
lmbind (MATERIAL,  DIRT); 
drawob ject (base, numbasepts) ; 

/*  draw  the  ground  */ 
lmbind (MATERIAL,  GRASS2) ; 
drawob ject (ground, numgroundpts) ; 

/•draw  path  */ 
drawpath () ; 

/*  turn  z-buffering  off  */ 
zbuffer (FALSE); 


/*  change  the  buffers  ...  */ 
swapbuffers () ; 


) 


initialize (threed,  twod) 

int  ‘thread,  *twod;  /*  for  display  window  and  controles  window  */ 

( 

int  xorigin,  yorigin; 

/*  set  up  the  preferred  aspect  ratio  */ 
keepaspect (XMAXSCREEN+1 , YMAXSCREEN+1 ) ; 

/*  open  main  window  */ 
winopen ("main”) ; 

/*  get  the  size  of  main  */ 
getsize (Sxwinsize,  Sywinsize) ; 

printf("x=  %ld  y=  %ld  \n" , xwinsize,  ywinsize) ; 

getor igin (txorigin,  Syorigin) ; 

printf("x*  %ld  y“  %ld  \n", xorigin,  yorigin); 

/*  set  the  size  of  the  path  window  */ 
prefposition (xorigin,  xorigin  +  xwinsize, 
yorigin,  yorigin  +  ywinsize) ; 


/*  open  a  window  for  the  program  */ 

•thread  «  winopen ("path") ; 

/*  make  a  title  */ 
wintitle ( "Path  Planning"); 

/*  put  the  IRIS  into  double  buffer  mode  •/ 
doublebuffer ( ) ; 

/*  put  the  iris  into  rgb  mode  •/ 

RGBmode ( ) ; 
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/*  configure  the  IRIS  (means  use  the  above  command  settings)  */ 
gconfig  ()  ; 

/*  set  the  depth  for  z-buffering  only  for  GT*/ 
lsetdepth (NEARDEPTH, FARDEPTH) ; 


/*  queue  the  redraw  device  */ 
qdevice (REDRAW) ; 

/*  queue  the  menubutton  */ 
qdevice (MENUBUTTON) ; 

/*  queue  up  dials  */ 
qdevice (DIALO) ; 
qdevice (DIAL1) ; 
qdevice (DIAL2) ; 

/*  turn  the  cursor  on  */ 
curson ( ) ; 

/*  select  gouraud  shading  */ 

/*  only  works  on  the  4D*/ 
shademode 1 (GOURAUD) ; 

/*  turn  on  the  new  projection  matrix  mode  */ 
mmode (MVIEW1NG) ; 


) 

/*  this  routine  resets/initaliied  the  dial  0  */ 

setdialO ( ) 

( 

setvaluator (DIALO, 

(O'sena)  , 

(-360  *  sens) , 

(  360  *  sens ) ) ; 
qreset  ( ) ; 

) 

/*  this  routine  resets/initalized  the  dial  1  */ 

setdiall () 

( 

setvaluator (DIAL1 , 

(0*sens) , 

(  0  *  sens) , 

(  89  »  sens) ) ; 
qreset ( ) ; 

) 

/*  this  routine  resets/initalized  the  dial  2  */ 

setdial2 ( ) 

< 

setvaluator (DIAL2, 

(int) (viewingdistance/sens) , 

(0), 

(500) ) ; 
qreset  ( )  ; 

) 
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/*  thia  routine  performs  all  the  menu  construction  calls  */ 


int  makethemenus ( ) 

( 


int  topmenu; 
int  rotmenu ; 
int  transmenu; 
int  acalemenu; 


/*  top  level  menu' a  name  */ 


trans  menu 
scale  menu 


rotmenu  »  nawpup ( ) ; 


transmenu  «  newpup ( ) ; 


addtopup (transmenu, "+Y  %xl5  | 


*/ 

*/ 

*/ 

first  */ 

%t  "); 

%x3  |  -X 

%x4 

"); 

%x6  |  -Y 

%x7 

") ; 

%x9  |  -Z 

%xlO 

"); 

Menu  %t  " 

>? 

OX  %xl3  | 

-X 

%xl4  "); 

OY  %xl6  | 

-Y 

%xl7  ”); 

OZ  %xl 9  | 

-Z 

%x20  " ) ; 

scalemenu  ■  newpupO; 

addtopup (acalemenu, "Scale  Menu  %t  ”); 
addtopup (scalemenu, "+X  %x22  I  OX  %x23  |  -X  %x24  "); 

addtopup (scalemenu, "+Y  %x25  |  Oy  %x26  I  -Y  %x27  "); 

addtopup (scalemenu, "+Z  %x28  |  OZ  %x29  I  -Z  %x30  "); 


/*  build  the  top  level  menu  */ 

topmenu  -  defpup("Roll  Off  Side  %t  I  Rotate  %xl  %m  |  Translate  %xll  %m  | 
Scale  %x21  %m  |  Reset  %x31  I  Exit  %x32  ", 

rotmenu, transmenu,  scalemenu) ; 


/*  return  the  name  of  this  menu  */ 
return (topmenu) ; 


198 


/*  this  routine  builds  the  moving  viewing  matrix  each  time  through 
the  display  loop... 

P'  «  p  .  T(to  origin)  .  S(acc)  .  R(x  acc)  .  R (y  acc)  .  R(z  aoc) 

.  T (to  acc.  loc)  .  T(baok  to  specified  center)  .  perspective ()  */ 


buildmovingviewingmatrix (vx, vy, vz, refx,refy, refz) 


float  vx,vy,vz;  /*  view  point  */ 

float  refx, refy, refz;  /*  ref  point  we  are  looking  towards  */ 

< 

/*  Build  the  accumulative  rotation  matrices  */ 
loadmatrix(rxacc) ;  /*  get  the  accumulative  rotation  */ 
rotate (rx, 'x' ) ;  /*  concatenate  on  the  new  rotation  (if  any)  */ 

getmatrix (rxacc) ;  /*  we  now  have  a  new  accumulative...  */ 


loadmatrix(ryacc) ; 
rotate  (ry, '  y' )  ; 
getmatrix (ryacc) ; 


/*  get  the  accumulative  rotation  */ 

/*  concatenate  on  the  new  rotation  (if  any) 
/*  we  now  have  a  new  accumulative...  */ 


*/ 


loadmatrix (rzacc)  ; 
rotate (rz, ' z' ) ; 
getmatrix (rzacc) ; 


/*  get  the  accumulative  rotation  */ 

/*  concatenate  on  the  new  rotation  (if  any)  */ 
/*  we  now  have  a  new  accumulative...  */ 


/*  Build  the  accumulative  translation  matrix  */ 


loadmatrix (transacc) ;  /*  get  the  accumulative  translation  */ 
tranalate(tx,ty,tz) ;  /*  concatenate  on  the  new  translation  */ 

getmatrix (transacc) ;  /*  we  now  have  a  new  accumulative  translation  */ 

/*  Build  the  accumulative  scale  matrix  */ 

loadmatrix (scaleacc ) ;  /*  get  the  accumulative  scale  */ 

scale (ax, sy, sz) ;  /*  concatenate  on  the  new  scale  */ 

getmatrix (scaleacc) ;  /*  we  now  have  the  new  accumulative  scale  */ 

/*  in  mmode (MVIEWING) ,  we  must  add  a  load  of  a  unit  matrix  */ 
loadunit ( ) ; 


/*  put  up  the  proj«ction  and  viewing  matrix  */ 
pro jectionandviewingmatrix (vx,  vy, vz, refx,  refy, ref z) ; 

/*  translate  center  of  box  back  to  original  location  */ 
translate (refx,  refy,  refz)  ; 

/*  translate  the  object  to  the  location  specified 
by  the  accumulative  translation. . . 

V 

multmatrix (transacc)  ; 

multmatrix (rzacc) ;  /*  z  accumulative  matrix  */ 

multmatrix (ryacc) ;  /*  y  accumulative  matrix  */ 

multmatrix (rxacc) ;  /*  x  accumulative  matrix  */ 

multmatrix(scaleacc) ;  /*  accumulative  scale  matrix  */ 

/*  translate  center  of  box  to  the  origin  */ 
translate (-refx, -refy,  -refz) ; 


199 


/*  for  objects  that  are  in  the  same  coordinate  system  but  aren't  moving 
with  the  continuous  rotations/translations/soalings,  we  use  this 
routine  ...  */ 

buildnonmovingviewingmatrix ( vx, vy, vz, refx, refy,ref z) 
float  vx,vy,  vz;  /*  view  point  */ 

float  refx, refy, ref z;  /*  reference  point  we  are  looking  towards  */ 

{ 


/*  we  must  call  loadunit  before  we  get  the  projection 
and  viewing  stuff...  */ 
loadunit (); 

/*  just  call  the  perspective  +  viewing  matrices  */ 
project ionandviewingmat r ix ( vx , vy , vz, refx, refy, refx) ; 


) 


/*  put  up  the  projection  and  viewing  matrix  */ 

projectionandviewingmatrix(vx, vy, vz, refx, refy, ref z) 

float  vx, vy, vz;  /*  view  point  */ 

float  refx, refy, refz;  /*  reference  point  */ 

( 


/*  perspective  projection  3D  for  the  world  coord  sys  */ 
/*  the  near  and  far  values  are  distances  from  the  viewer 
to  the  near  and  far  clipping  planes. 

We  are  at  (vx,vy,vz)  and  looking  towards 
the  center  point  of  the  object.. 

(towards  (refx, refy, ref z) ) . 

*/ 

perspective (450, 1 . 00, NEARCLIPPING, FARCLIPPING) ; 
lookat (vx, vy, vz, refx, refy,  refz,  0)  ; 


) 


1 
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/*  process  the  popup  menu  selection  */ 
processmenuhit (hititem) 


int  hititem;  /*  item  hit  on  the  popup  menus  */ 

< 

switch (hititem) 

{ 

case  ROTATE : 

break; 

case  PLUSXROT: 

rx  -  XROTAMOONT; 
break; 

case  ZEROXROT: 

rx  -  0; 
break; 

case  MINUSXROT : 

rx  -  -  XROTAMOUNT; 
break; 

case  PLUSYROT: 

ry  -  YROTAMOUNT; 
break; 

case  ZEROYROT : 

ry  «  0; 
break; 

case  MINUS YROT : 

ry  =  -  YROTAMOUNT; 
break; 

case  PLUSZROT: 

rz  «  ZROTAMOUNT; 
break; 

case  ZEROZROT : 

rz  =  0; 
break; 

case  MINUSZROT : 

rz  =  -  ZROTAMOUNT; 
break; 


case  TRANSLATE: 

break; 

case  PLUSXTRANS : 

tx  =  XTRANSAMOUNT; 
break; 

case  ZEROXTRANS: 

tx-0 ; 
break; 

case  MINUSXTRANS: 

tx-  -XTRANSAMOUNT; 
break; 

case  PLUSYTRANS: 

ty-YTRANSAMOUNT; 

break; 

case  ZEROYTRANS: 

ty-0.0; 

break; 

case  MINUSYTRANS : 

ty-  -YTRANSAMOUNT; 
break; 
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case  PLUSZTRANS: 

tz-ZTRANSAMOUNT; 

braak; 

case  ZEROZTRANS: 

tz-O.O; 

break; 

case  MINUSZTRANS: 

tz«  -ZTRANSAMOUNT; 
break; 

case  SCALE : 

break; 

case  PLUSXSCALE: 

ax  -  POSSCALEAMOUNT; 
break ; 

case  ZEROXSCALE: 

sx  -  1.0; 
break; 

case  MINUSXSCALE: 

ax  >  NEGSCALE AMOUNT; 
break; 

case  PLUSYSCALE: 

sy  ■  POSSCALEAMOUNT; 
break; 

case  ZEROYSCALE: 

sy  »  1.0; 
bre ak; 

case  MINUSYSCALE: 

ay  «*  NEGSCALEAMOUNT; 
break; 

case  PLUSZSCALE: 

az  -  POSSCALEAMOUNT; 
break; 

case  ZEROZSCALE ■ 

sz  »  1.0; 
break; 

case  MINUSZSCALE: 

az  «  NEGSCALEAMOUNT; 
break; 

case  RESET: 

/*  zap  all  values...*/ 
resetallaccumulativematrices () 

break; 

case  EXIT: 

exit (0) ; 
break; 

default : 

break; 


/*  end  switch  */ 


/*  the  following  routlna  sata  all  aocumulativa  matrioas  to  unit  matrices  */ 

resetallaccumulativematricea {) 

< 

unit (tranaacc) ;  /*  aat  tha  trana  aocumulativa  */ 

unit(rxacc);  /*  aat  tha  x  rotation  aocumulativa  */ 

unit(ryaoc);  /*  aat  the  y  rotation  accumulative  */ 

unit(rzacc);  /*  aat  tha  z  rotation  accumulative  */ 

unit (acaleacc) ;  /*  aat  the  acala  accumulative  */ 

/*  reset  all  tha  ON  valuaa  to  off...  */ 
rx  -  0; 
ry  -  0; 
rz  -  0; 

tx  «  0.0; 
ty  -  0.0; 
t  z  ■  0.0; 

sx  «  1.0; 
ay  =  1.0; 
sz  «  1.0; 


/*  the  following  routine  loads  a  unit  matrix  into  tha  input  array  */ 

unit (m) 

Matrix  m; 

( 

static  Matrix  un  -  {  1.0,  0.0,  0.0,  0.0, 

0.0,  1.0,  0.0,  0.0, 

0.0,  0.0,  1.0,  0.0, 

0.0,  0.0,  0.0,  1.0  ) ; 

long  i,  j; 

/*  copy  the  matrix  elements...*/ 
for(i*0;  i  <  4;  i*>i  +  l) 

< 

for  ( j*=0;  j  <  4;  j«=j+l) 

( 

m l i ]  [ j ] -un [ i ]  [  j ] ; 

} 

) 


/*  this  routine  loads  a  unit  matrix  onto  tha  top  of  the  stack  */ 

loadunit  () 

< 


static  Matrix  un  -  {  1.0, 

0.0, 

0.0,  0.0, 

0.0, 

1.0, 

0.0,  0.0, 

0.0, 

0.0, 

1.0,  0.0, 

0.0, 

0.0, 

0.0,  1.0  ); 

/*  load  tha  matrix  */ 
loadmatrix(un) ; 
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/*  Thia  auction  reads  in  tha  data  arraya  baaa  and  ground  •/ 
inputstruetura (base,  numpolygons,  filename) 
struct  threedob j  base [ ] ; 
int  ‘numpolygons; 
char  filename l 20 ] ; 

< 

FILE  * inpfl; 
int  i,  j; 
int  polygons; 

inpfl  -  fopen(filename,  "r")  ; 
fscanf (inpfl,  "%d",  numpolygons) ; 

for  (i«0;  i<*numpolygons;  i++) 

( 

fscanf (inpfl,  "%d",  tbasefi] .numpta) ; 

for  (j-0;  j<basa(i] .numpta;  j++) 

( 

fscanf (inpfl,  "%f%f%f", 

t (bass (i] .point (j] (0] ) , 
t (base [i] .point ( j] (1] ) , 
t (base [i] .point ( j] [2] ) ) ; 


lifdef  TRACE 

printf ("points (%d] (0]«%.f  points[%d] (l]-%.f  pointa[%d] (2]«%.f\n", 
j , base ( i } . point  t  j ] { 0  J , 
j,  base [i] .point ( j]  (1] , 
j,  base  [i]  .point  (  j]  12] )  ; 

tendif 

>; 

» ; 

f close (inpfl ) ; 

); 
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/*  Computes  normal  for  polygon  and  raordera  polygon  points  to 
counterclockwise  if  given  in  clockwise  order.  ax,ay,az  must 
be  an  interior  point  of  polygon  in  order  to  orient  the  normal 
vector  in  correct  location.  */ 
calculatenormal (xyz,  numpts,  ax, ay,az) 
struct  threedobj  xyz[]; 

int  numpts;  /*  number  of  polygons  in  the  xyz  array  */ 
float  ax,ay,az;  /*  interior  point  of  the  whole  object.  */ 

{ 


float  txyz IMAXPOINTS] (3];  /*  temp  coord  hold 

long  h, i, j;  /*  loop  temps  V 


•/ 


long  ncoords; 
int  npoly_orient ( ) ; 
float  vl[3],v2[3]; 
float  normalmag; 
float  lightmag; 
float  normal [3]; 
float  vlmag,v2mag; 
double  vecmagO; 


/*  looping  for  each  polygon  */ 

/*  direction  test  function  */ 

/*  vectors  used  to  compute  the  polygon's  normal  */ 
/*  normal's  magnitude  */ 

/*  magnitude  of  the  light  vector  */ 

/*  tempory  storage  for  normal  */ 


for  (h»0;  hcnunpts;  h++) 

< 

tifdef  TRACE 

printf ( ”\nlorient  xyz  [] (0-2]\nM); 
for  (i*0;  i<ncoords;  i++) 

printf ("  xyz(%d]  %f  %f  %f\n" , i, xyz [ i ] [ 0] , xyz [i] [ 1] , xyz [i] [2] ) ; 
printf ("  ax, ay, az  %f  %f  %f\n", ax, ay, az) ; 
tendif 

/*  check  the  number  of  coords  in  the  input  array  */ 
if (xyz lh] .numpts  >  MAXPOINTS) 

( 

printf ("LIGHTORIENT:  too  many  coords  passed  to  me!  “  %d\n" , ncoords ) ; 
exit (1) ; 

) 

/*  orient  the  polygon  so  that  its  CCW  with  respect  to  the  interior  point  */ 
/*  this  section  removed  tempory.  will  replace  next  quarter 
if (npoly_orient (ncoords, xyz, ax, ay, az)  —  1) 

( 

*/  /*  the  polygon  is  clockwise,  reverse  it.  */ 

/*  for(i«=0;  i  <  ncoords;  i=i+l) 


( 

for ( j”0 ;  j  <  3;  j-j+1) 

< 

txyz(i)(j)  -  xyz [ncoords-i-1 ) [ j) ; 

) 

) 

for(i«0;  i  <  ncoords;  ++i) 

( 

for  (j-0;  j  <  3;  ++j) 

( 

xyz (i] (j)  -  txyz(ij ( j); 

) 

» 

tifdef  TRACE 

printf ("lorient  pts  reversed\n") ; 
for  (i«0;  i<ncoords;  i++) 

printf ("  xyz [ %d]  %f  %f  %f \n", i, xyz (i] [0] , xyz [i] [1] , xyz [i] (2) ) ; 

tendif 


*/ 


) 
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/*  the  coordinates  ara  ordarad  counterclockwise  in  array  xyz  */ 

/*  coirputa  tha  normal  vactor  for  tha  polygon  uaing  tha  first  3  varticas  */ 

/*  computa  tha  first  vactor  to  usa  in  tha  computation  */ 
vl[0]  -  xyz (h) .point (2] [0]  -  xyz (h] .point [1 ] [0] ; 
vl(l]  -  xyz (hj .point [2] 11]  -  xyz [h] .point [1] ( 1] ; 
vl [2]  -  xyz [h] .point [2] [2]  -  xyzjh] .point [1] (2) ; 

/*  computa  tha  saoond  vactor  to  usa  in  computing  tha  normal  */ 
v2{0]  -  xyz (h] .point [0] [0]  -  xyz [h] .point [1 ] [0] ; 
v2(l]  -  xyz [h] .point [0] Jl]  -  xyz [h] .point [1] (1) ; 
v2 [2]  -  xyz]h] .pointtO] 12]  -  xyz [h] .point ]1] ]2) ; 

/*  tha  normal  is  vl  x  v2  */ 
normal [0]  -  vltl]*v2[2]  -  vl(2]*v2(l]; 

normal (1]  -  vlt2]*v2l0]  -  vl[0]*v2[2]; 

normal [2]  -  vl[0]*v2ll]  -  vl[l]*v2[0]; 

tifdaf  TRACE 

printf ("loriant  normal  bafora  mag  div  %f  %f  %f\n" , normal [0] , 
normal l 1] , normal [2] ) ; 

landif 

normalmag  «  (float) (vacmag) ((double) (normal [0]), (double) (normal [1]), 

(double) (normal [2] ) ) ; 

xyz [h] .normal [0]  -  normal{0]  /  normalmag; 
xyz [h] .normal ( 1 ]  «  normal (1]  /  normalmag; 
xyz [h] .normal [2]  -  normal [2]  /  normalmag; 

tifdaf  TRACE 

printf ("loriant  normal  %f  %f  %f\n", normal (0] , normal l 1 ] , normal [2] ) ; 
landif 


)  /*  and  of  for  h  ...  * / 

) 

/*  this  procedure  computes  the  vactor  mag  for  use  of  making  the  unit  vector*/ 
double  vacmag  (x,  y,  z) 
float  x, y, z; 

( 

double  tl, t2, t3, t4, t5; 

tl  «  ( (double)  (x) )  *  ( (double) (x) ) ; 
t2  “  ( (double) (y) )  *  ( (double) (y) ) ; 
t3  «  ( (double) (z) )  *  ( (double) (z) ) ; 
t4  •  tl  +  t2  +  t3; 
t5  «  aqrt(t4); 

tifdaf  TRACE 

printf ("vacmag  tl,t2,t3,t4  %f  %f  %f  %f\n”, tl, t2, t3, tt ) ; 
printf ("vacmag  x,y,z,mag  %f  %f  %f  %f\n",x, y, z,t5) ; 
tendif 

return (t5) ; 

) 


206 


/*  this  draws  tha  object  that  is  passed  in  */ 
drawob ject (object, numpolygons) 
struct  threedobj  object!); 
int  numpolygons; 

! 

int  h, i, j  ;  /*  loop  temps  */ 

for  (h«0;  h<numpolygons;  h++) 

{ 

normal (ob ject (hi .normal) ; 

pmv( object [hj .point  JO] {0] , object [h] .point [0] [1] ,  object [h] .point [0] [2) ) 
for  (i-1;  i<ob ject (h) .numpta;  i++) 

< 

pdr (object [h] .point [i] (0) , 
object [h] .point(i) (1) , 
object [h] .point [i] [2] ) ; 

) 

pclos ( ) ; 

) 

) 

/*  This  section  reads  in  tha  path  of  the  missile  to  be  displayed  */ 
inputlinearray  <) 

( 

FILE  *inpf ; 
int  i,  j; 

inpf  *=  fopenCpathl.dat",  "r"); 
fscanf (inpf,  "%d", (numberof paths) ; 
for  (i*»0;i<numberofpaths;i+4) 

{  fscanf (inpf,  "%d", inumberof waypoints [i] ) ; 

) 

for  ( j“0; j<numberofpaths; j++) 

( 

for  (i=0; i<numberofwaypoints ( j) ; i++) 

( 

fscanf (inpf,  "%f%f%f%f", 

(waypoints ( j ) ( i ) [ 0 ) , (waypoints [ j ) [ i ) [ 1 ) , 

(waypoints [ j] [i] [2] , (waypoints [ j) [ i ] [3] ) ; 


fclose (inpf) ; 

) 

/*  draw  the  path  of  the  missile  with  color  shading  for  %  observation  */ 
drawpath ( ) 

{ 

int  i*0,  j,  redtint; 

for  ( j=0 ; j<numberofpaths ; j++) 

{ 

redtint  =  (int) (255-255*waypoints t j] (0) (3) ) ; 

RGBcolor (255, redtint, 45) ; 

move (waypoints [ j ] (0) (0) , waypoints [ j] [0] [ 1) , waypoints [ j) [0] (2) ) ; 
linewidth (3)  ; 

for (i”l; iCnumber of waypoints [ j] ; i++) 

< 

redtint  -  (int) (255-255*waypoints I j] [i] [3] ) ; 

RGBcolor (255, redtint, 45) ; 

draw (waypoints ( j J [ i ) (0) , waypoints ( j) [i] [1] , waypoints [ j] [i] [2] ) ; 

) 

> 

linewidth (3) ; 

) 
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/*  this  is  fils  rotate. h 


It  is  the  include  file  for  program  rotate. c 

This  file  holds  the  defines  and  the  global  variables 

for  programs: 

rotate . c 

rotate2.c 


*/ 

/*  defines  for  the  menu  definition  routine  */ 

♦define  ROTATE  1 

♦define  PLUSXROT  2 
♦define  ZEROXROT  3 
♦define  MINUSXROT  4 

♦define  PLtJSYROT  5 
♦define  ZEROYROT  6 
♦define  MINUSYROT  7 

♦define  PLUSZROT  8 
♦define  ZEROZROT  9 
♦define  MINUSZROT  10 


♦define  TRANSLATE  11 

♦define  PLUSXTRANS  12 
♦define  ZEROXTRANS  13 
♦define  MINUSXTRANS  14 

♦define  PLUSYTRANS  15 
♦define  ZEROYTRANS  16 
♦define  MINUSYTRANS  17 

♦define  PLUSZTRANS  18 
♦define  ZEROZTRANS  19 
♦define  MINUSZTRANS  20 


♦define  SCALE  21 

♦define  PLUSXSCALE  22 
♦define  ZEROXSCALE  23 
♦define  MINUSXSCALE  24 

♦define  PLUSYSCALE  25 
♦define  ZEROYSCALE  26 
♦define  MINUSYSCALE  27 

♦define  PLUSZSCALE  28 
♦define  ZEROZSCALE  29 
♦define  MINUS2SCALE  30 


♦define  RESET  31 


♦define  EXIT  32 
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/*  the  following  defines  tr*  the  amounts  concatenated 
aach  frame  if  tha  matrix  conoatanation  ia  aalaotad 
aa  ON 


*/ 

♦define 

XROT AMOUNT  25 

/* 

2 

♦define 

YROT AMOUNT  25 

/* 

2 

♦define 

ZROT AMOUNT  25 

/* 

2 

♦define 

XTRANSAMOUNT  5 

.0; 

/ 

♦define 

YTRANSAMOUNT  5 

.0; 

/ 

♦define 

ZTRANS AMOUNT  5 

.0; 

/' 

♦define 

NEGSCA1E AMOUNT 

0. 

99 

♦define 

POSSCALEAMOUNT 

1. 

01, 

.5  dagraaa  of  rotation  aach  pictura  */ 

.5  dagraaa  of  rotation  aach  pictura  */ 

.5  dagraaa  of  rotation  aach  pictura  */ 

*  5  units  of  translation  in  tha  x  diraction  */ 

*  5  units  of  translation  in  tha  y  diraction  */ 

*  5  units  of  translation  in  tha  z  diraction  */ 


99  acala  aach  frama  if  ON 
01  acala  aach  frama  if  ON 


/*  tha  following  variables  ara  sat  whan  tha  particular  matrix 
concatenation  is  turned  ON.  Otherwise  they  ara  zero... 

*/ 


static 

float 

tx; 

/* 

translation 

on 

in 

the  x  diraction 

*/ 

static 

float 

ty; 

/* 

translation 

on 

in 

tha  y  direction 

*/ 

static 

float 

tz; 

/* 

translation 

on 

in 

the  z  diraction 

*/ 

static 

short 

rx; 

/* 

rotation 

on 

in 

tha 

i  x  direction 

*/ 

static 

short 

ry; 

/* 

rotation 

on 

in 

tha 

y  direction 

*/ 

static 

short 

rz; 

/* 

rotation 

on 

in 

tha 

t  z  diraction 

*/ 

static 

float 

sx; 

/* 

scale  on 

in 

tha 

>  X 

diraction  */ 

static 

float 

»y  ; 

/* 

scale  on 

in 

tha 

y 

direction  */ 

static 

float 

sz; 

/* 

scale  on 

in 

tha 

z 

direction  */ 

/*  some  globally  defined  matrices  for  the  viewing  matrix  computation  */ 


static 

Matrix 

transacc; 

/* 

accumulative 

translation  matrix 

V 

static 

Matrix 

rxacc; 

/* 

accumulative 

x  rotation  matrix 

V 

static 

Matrix 

ryacc; 

/* 

accumulat ive 

y  rotation  matrix 

V 

static 

Matrix 

rzacc; 

/* 

accumulative 

z  rotation  matrix 

*/ 

static 

Matrix 

acaleacc; 

/* 

accumulative 

scale  matrix  */ 
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/*  this  ia  file  lightdefs.c 

These  routines  define  the  mater ials/lighta/lighting  models  needed.. 

V 

f include  "gl.h" 

(include  "lightdef a .h" 

/*  set  up  all  the  materials  */ 

initializematerials ( ) 

< 

/*  make  the  definition  calls  for  the  materials  */ 

/*  make  the  defs  for  the  terrain  */ 
lmdef (DEFMATERIAL, DIRT, 19,  dirt) ; 
lmdef (DEFMATERIAL, GRASS1, 19, graaal); 
lmdef (DEFMATERIAL,  GRASS2, 19, grass2) ; 
lmdef (DEFMATERIAL, GRASS3,  19,graas3)  ; 

/*  make  the  material  for  where  the  light  is  */ 
lmdef (DEFMATERIAL, LIGHTMATERIAL, 19, lightmaterial) ; 

) 

/*  this  routine  seta  up  the  light  for  the  scene  */ 

initializelights () 

I 

/*  define  the  light  */ 

lmdef (DEFLIGHT, MYLIGHT, 14, light) ; 

/*  turn  this  light  on  */ 
lmbind(LIGHTO, MYLIGHT) ; 

) 

/*  define  the  lighting  model  */ 

initializelmodel () 

( 

/*  define  the  lighting  model  */ 
lmdef (DEFLMODEL, MYMODEL, 10, lmodel) ; 

/*  turn  on  the  model  */ 
lmbind (LMODEL, MYMODEL) ; 

) 

/*  the  following  routine  calls  routine  normal ()  with  3  args  */ 
xyznormal (x, y, z) 

float  x, y, z;  /*  input  normal  vector  */ 


float  tmpl3];  /*  array  to  hold  the  normal  */ 

tmp [ 0 ]  «  x; 
tmpll)  -  y; 
tmp [2 ]  -  z; 

normal (tmp) ; 
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/*  this  is  file  lightdefa.h 

It  is  the  file  containing  the  materiel/light/lighting  model  defs 

*/ 


♦define  MYSHININESS  10.0  /*  my  value  for  E(mas)  */ 

♦define  LIGHTMATERIAL  9 


static  float  lightmaterial [ ]  «  ( 

EMISSION, 

AMBIENT, 

DIFFUSE, 

SPECULAR, 

SHININESS, 

LMNULL 


1.0,  1.0, 

0.0,  0.0, 

0.0,  0.0, 

0.0,  0.0, 

0.0, 


); 


1.0, 

0.0, 

0.0, 

0.0, 


/*  set  up  the  light  defs  for  the  program  */ 


♦define  MYLIGHT  10 

♦define  LIGHTX  200.0  /*  loc  of  the  light  */ 

♦define  LIGHTY  100.0 
♦define  LIGHTZ  -350.0 

static  float  light []  *  ( 

AMBIENT,  0.2,  0.20,  0.20, 

LCOLOR,  1.0,  1.0,  1.0, 

POSITION,  0.0,  0.707106,  0.707106,  0.0, 
LMNULL 

}  ; 

/*  define  the  lighting  model  */ 

♦define  MYMODEL  11 
static  float  lmodel(]  «  { 

AMBIENT,  0.20,  0.20,  0.20, 

LOCALVIEWER,  0.0, 

ATTENUATION,  1.0,  0.0000, 

LMNULL 

); 
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/*  setup  terrain  definitions  */ 

♦define  DIRT  12 
static  float  dirt [ ]  -  { 

EMISSION,  0.0,  0 
AMBIENT,  0.47,  I 
DIFFUSE,  0.47,  ( 
SPECULAR,  0.0,  0 
SHININESS,  0.0, 
LMNULL 

,  ); 

♦define  GRASS1  13 

static  float  grasalf]  -  { 

EMISSION,  0.0,  0. 
AMBIENT,  0.325,  0 
DIFFUSE,  0.345, 
SPECULAR,  0.,  0.0 
SHININESS,  0.0, 
LMNULL 

♦define  GRASS2  14 
static  float  graas2[]  -  { 

EMISSION,  0.0,  0. 
AMBIENT,  0.2549, 
DIFFUSE,  0.2549, 
SPECULAR,  0.0  ,0. 
SHININESS,  0.0, 
LMNULL 

♦define  GRASS3  15  ’ 

static  float  graas3(]  =  { 

EMISSION,  0.0,  0 . ( 
AMBIENT,  0.0,  0.1 
DIFFUSE,  0.2549, 
SPECULAR,  0.2549, 
SHININESS,  10.0, 
LMNULL 

); 


0,  0.0, 
'.31,  0.0, 
'-31,  0.0, 
0,  0.0, 


0,  0.0, 
1.775,  0.0, 
0.775,  0.0, 
0.0, 


0.0, 

0.61,  0.0, 

0.61,  0.0, 

,  0.0, 


I,  0.0, 

,  0.1, 
0.41,  0.0, 
0.41,  0.0, 
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/*  This  is  the  Makefile  for  ppgh.c  */ 

CFLAGS  - 

ALL  “  ppgh 

all:  $ (ALL) 

clean: 

rm  -f  * . o 

delete : 

rm  -f  *.o  $ (ALL) 

ppgh:  ppgh . o  rotate. h  lightdefs.h  lightdefa.o 
cc  -o  ppgh  ppgh . o  lightdefs.o  -Zg  $ (CFLAGS) 

ppgh.o:  lightdefs.h 

lightdefs.o:  lightdefs.h 
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